home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / prims.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-03-22  |  81.8 KB  |  3,167 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * prims.c:    Copyright (c) Mark P Jones 1991, 1992.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.28 November 1992
  5.  *
  6.  *        Last updated March 93 kh
  7.  *        Added Macintosh support, hyperbolic trig functions,
  8.  *        and hexadecimal operations.
  9.  *
  10.  * Primitive functions, input output etc...
  11.  * if PRIMITIVES_CODE == 0 then the code for PRIMITIVES is excluded: only
  12.  * the primitives table and consChar() parts are retained.
  13.  * ------------------------------------------------------------------------*/
  14.  
  15. #if PRIMITIVES_CODE
  16.  
  17.  
  18. #if MPW
  19. /* Cell's already defined for lists */
  20. #define Cell __Cell__
  21. #include "mac_hdrs.h"
  22. #include "mac_ctype.h"
  23. #undef Cell
  24. #else
  25. #include <ctype.h>
  26. #endif
  27.  
  28. #if (TURBOC | BCC)
  29. #include <io.h>
  30. #endif
  31. #endif
  32.  
  33. /* --------------------------------------------------------------------------
  34.  * Local function prototypes:
  35.  * ------------------------------------------------------------------------*/
  36.  
  37. #if PRIMITIVES_CODE
  38. #define PROTO_PRIM(name)    static Void name Args((StackPtr))
  39. #define primFun(name)        static Void name(root) StackPtr root;
  40. #define primArg(n)        stack(root+n)
  41.  
  42. /* IMPORTANT: the second element of an update must be written first.
  43.  * this is to deal with the case where an INDIRECT tag is written into
  44.  * a Cell before the second value has been set.  If a garbage collection
  45.  * occurs before the second element was set then the INDIRECTion will be
  46.  * (wrongly) elided and result in chaos.  I know.  It happened to me.
  47.  */
  48.  
  49. #define update(l,r)        ((snd(stack(root))=r),(fst(stack(root))=l))
  50. #define updateRoot(c)        update(INDIRECT,c)
  51. #define updapRoot(l,r)        update(l,r)
  52. #define cantReduce()        evalFails(root)
  53.  
  54. PROTO_PRIM(primFatbar);
  55. PROTO_PRIM(primFail);
  56. PROTO_PRIM(primSel);
  57. PROTO_PRIM(primIf);
  58. PROTO_PRIM(primStrict);
  59.  
  60. PROTO_PRIM(primPlusInt);
  61. PROTO_PRIM(primMinusInt);
  62. PROTO_PRIM(primMulInt);
  63. PROTO_PRIM(primDivInt);
  64. PROTO_PRIM(primQuotInt);
  65. PROTO_PRIM(primModInt);
  66. PROTO_PRIM(primRemInt);
  67. PROTO_PRIM(primNegInt);
  68.  
  69. PROTO_PRIM(primCharToInt);
  70. PROTO_PRIM(primIntToChar);
  71. PROTO_PRIM(primIntToFloat);
  72.  
  73. PROTO_PRIM(primPlusFloat);
  74. PROTO_PRIM(primMinusFloat);
  75. PROTO_PRIM(primMulFloat);
  76. PROTO_PRIM(primDivFloat);
  77. PROTO_PRIM(primNegFloat);
  78.  
  79. #if HAS_FLOATS
  80. PROTO_PRIM(primSinFloat);
  81. PROTO_PRIM(primCosFloat);
  82. PROTO_PRIM(primTanFloat);
  83. PROTO_PRIM(primAsinFloat);
  84. PROTO_PRIM(primAcosFloat);
  85. PROTO_PRIM(primAtanFloat);
  86. PROTO_PRIM(primAtan2Float);
  87. PROTO_PRIM(primExpFloat);
  88. PROTO_PRIM(primLogFloat);
  89. PROTO_PRIM(primLog10Float);
  90. PROTO_PRIM(primSqrtFloat);
  91. PROTO_PRIM(primFloatToInt);
  92. #endif
  93.  
  94. #if HAS_HYPERBOLICS
  95. PROTO_PRIM(primSinhFloat);
  96. PROTO_PRIM(primCoshFloat);
  97. PROTO_PRIM(primTanhFloat);
  98. PROTO_PRIM(primAsinhFloat);
  99. PROTO_PRIM(primAcoshFloat);
  100. PROTO_PRIM(primAtanhFloat);
  101. #endif
  102.  
  103. PROTO_PRIM(primEqInt);
  104. PROTO_PRIM(primLeInt);
  105.  
  106. PROTO_PRIM(primEqChar);
  107. PROTO_PRIM(primLeChar);
  108.  
  109. PROTO_PRIM(primEqFloat);
  110. PROTO_PRIM(primLeFloat);
  111.  
  112. PROTO_PRIM(primCmp);
  113. PROTO_PRIM(primGenericEq);
  114. PROTO_PRIM(primGenericLe);
  115. PROTO_PRIM(primGenericLt);
  116. PROTO_PRIM(primGenericGe);
  117. PROTO_PRIM(primGenericGt);
  118. PROTO_PRIM(primGenericNe);
  119.  
  120. PROTO_PRIM(primPrint);
  121. PROTO_PRIM(primNPrint);
  122.  
  123.  
  124. /* C Monad Primitives for the Mac -- KH */
  125. #if MAC
  126. PROTO_PRIM(primUnitIO);
  127. PROTO_PRIM(primCUnitIO);
  128. PROTO_PRIM(primBindIO);
  129. PROTO_PRIM(primCBindIO);
  130. PROTO_PRIM(primCCBindIO);
  131.  
  132. PROTO_PRIM(primTrap);
  133. PROTO_PRIM(primTrapReg);
  134. PROTO_PRIM(primMalloc);
  135. PROTO_PRIM(primAssign);
  136. PROTO_PRIM(primAssignS);
  137. PROTO_PRIM(primAssignC);
  138. PROTO_PRIM(primAssignBlock);
  139. PROTO_PRIM(primDeref);
  140. PROTO_PRIM(primFree);
  141. PROTO_PRIM(primSeq);
  142. PROTO_PRIM(primTrace);
  143.  
  144. PROTO_PRIM(primButton);
  145. PROTO_PRIM(primGetMouse);
  146. PROTO_PRIM(primLineTo);
  147. PROTO_PRIM(primMoveTo);
  148. PROTO_PRIM(primGetNextEvt);
  149. PROTO_PRIM(primEvtAvail);
  150.  
  151. PROTO_PRIM(primCreateCallback);
  152. PROTO_PRIM(primDisposeCallback);
  153. #endif
  154.  
  155.  
  156. /* And some "bit-twiddling" primitives, which are generally useful. KH */
  157. #if BIT_OPERATIONS
  158. PROTO_PRIM(primBAnd);
  159. PROTO_PRIM(primBOr);
  160. PROTO_PRIM(primBComp);
  161. PROTO_PRIM(primBASL);
  162. PROTO_PRIM(primBASR);
  163. PROTO_PRIM(primBTst);
  164. PROTO_PRIM(primBSet);
  165. PROTO_PRIM(primBClr);
  166. PROTO_PRIM(primBLSet);
  167. PROTO_PRIM(primBHSet);
  168. #endif
  169.  
  170. static Void   local printer        Args((StackPtr,Name,Int,Cell));
  171. static Void   local startList        Args((StackPtr,Cell));
  172. static Void   local startNList        Args((StackPtr,Cell));
  173.  
  174. PROTO_PRIM(primLPrint);
  175. PROTO_PRIM(primNLPrint);
  176. PROTO_PRIM(primSPrint);
  177. PROTO_PRIM(primNSPrint);
  178.  
  179. static Cell   local textAsVar        Args((Text,Cell));
  180. static Cell   local textAsOp        Args((Text,Cell));
  181. static Cell   local stringOutput    Args((String,Cell));
  182. static Cell   local printBadRedex    Args((Cell,Cell));
  183.  
  184. static String local evalName        Args((Cell));
  185. static Void   local abandonDialogue    Args((Cell));
  186. static Cell   local printDBadRedex    Args((Cell,Cell));
  187. static Cell   local readFile        Args((Void));
  188. static Cell   local writeFile        Args((Void));
  189. static Cell   local appendFile        Args((Void));
  190. static Cell   local readChan        Args((Void));
  191. static Cell   local appendChan        Args((Void));
  192. static FILE  *local validOutChannel    Args((String));
  193. static Cell   local echo        Args((Void));
  194. static Cell   local getCLArgs        Args((Void));
  195. static Cell   local getProgName        Args((Void));
  196. static Cell   local getEnv        Args((Void));
  197. #if MAC
  198. static Cell   local imperate        Args((Void));
  199. #endif
  200.  
  201. PROTO_PRIM(primInput);
  202. PROTO_PRIM(primFopen);
  203.  
  204. #ifdef LAMBDAVAR
  205. PROTO_PRIM(primLvReturn);
  206. PROTO_PRIM(primLvPure);
  207. PROTO_PRIM(primLvRead);
  208. PROTO_PRIM(primLvBind);
  209. PROTO_PRIM(primLvVar);
  210. PROTO_PRIM(primLvNewvar);
  211. PROTO_PRIM(primLvAssign);
  212. PROTO_PRIM(primLvVarEq);
  213. PROTO_PRIM(primLvGetch);
  214. PROTO_PRIM(primLvPutchar);
  215. PROTO_PRIM(primLvSystem);
  216. #endif
  217.  
  218. #ifdef LAMBDANU
  219. PROTO_PRIM(primLnReturn);
  220. PROTO_PRIM(primLnBind);
  221. PROTO_PRIM(primLnFlip);
  222. PROTO_PRIM(primLnNew);
  223. PROTO_PRIM(primLnAssign);
  224. PROTO_PRIM(primLnRead);
  225. PROTO_PRIM(primLnIo);
  226. PROTO_PRIM(primLnBegin);
  227. PROTO_PRIM(primLnTagEq);
  228. PROTO_PRIM(primLnGetch);
  229. PROTO_PRIM(primLnPutchar);
  230. PROTO_PRIM(primLnSystem);
  231. PROTO_PRIM(primLnDone);
  232. #endif
  233.  
  234. #endif
  235.  
  236. /* --------------------------------------------------------------------------
  237.  * Table of primitive/built-in values:
  238.  * ------------------------------------------------------------------------*/
  239.  
  240. #if PRIMITIVES_CODE
  241. #define GofcPrim(imp)    imp
  242. #define NoGofcPrim(imp)    imp
  243. #else
  244. #define GofcPrim(imp)    PRIM_GOFC
  245. #define NoGofcPrim(imp)    PRIM_NOGOFC
  246. #endif
  247.  
  248. struct primitive primitives[] = {
  249.   {"primFatbar",    2, GofcPrim(primFatbar)},
  250.   {"primFail",        0, GofcPrim(primFail)},
  251.   {"primUndefMem",    1, GofcPrim(primFail)},
  252.   {"primGCBhole",    0, NoGofcPrim(primFail)},
  253.   {"primError",        1, GofcPrim(primFail)},
  254.   {"primSel",        3, GofcPrim(primSel)},
  255.   {"primIf",        3, GofcPrim(primIf)},
  256.   
  257.   {"primCompare",    1, NoGofcPrim(primCmp)},
  258.   {"primInput",        1, NoGofcPrim(primInput)},
  259.   {"primPrint",        3, NoGofcPrim(primPrint)},
  260.   {"primNprint",    3, NoGofcPrim(primNPrint)},
  261.   {"primLprint",    2, NoGofcPrim(primLPrint)},
  262.   {"primNlprint",    2, NoGofcPrim(primNLPrint)},
  263.   {"primSprint",    2, NoGofcPrim(primSPrint)},
  264.   {"primNsprint",    2, NoGofcPrim(primNSPrint)},
  265.   
  266.   {"primPlusInt",    2, GofcPrim(primPlusInt)},
  267.   {"primMinusInt",    2, GofcPrim(primMinusInt)},
  268.   {"primMulInt",    2, GofcPrim(primMulInt)},
  269.   {"primDivInt",    2, GofcPrim(primDivInt)},
  270.   {"primQuotInt",    2, GofcPrim(primQuotInt)},
  271.   {"primModInt",    2, GofcPrim(primModInt)},
  272.   {"primRemInt",    2, GofcPrim(primRemInt)},
  273.   {"primNegInt",    1, GofcPrim(primNegInt)},
  274.   
  275.   {"primPlusFloat",    2, GofcPrim(primPlusFloat)},
  276.   {"primMinusFloat",    2, GofcPrim(primMinusFloat)},
  277.   {"primMulFloat",    2, GofcPrim(primMulFloat)},
  278.   {"primDivFloat",    2, GofcPrim(primDivFloat)},
  279.   {"primNegFloat",    1, GofcPrim(primNegFloat)},
  280.   
  281.   #if HAS_FLOATS
  282.   {"primSinFloat",    1, GofcPrim(primSinFloat)},
  283.   {"primCosFloat",    1, GofcPrim(primCosFloat)},
  284.   {"primTanFloat",    1, GofcPrim(primTanFloat)},
  285.   {"primAsinFloat",    1, GofcPrim(primAsinFloat)},
  286.   {"primAcosFloat",    1, GofcPrim(primAcosFloat)},
  287.   {"primAtanFloat",    1, GofcPrim(primAtanFloat)},
  288.   {"primAtan2Float",    2, GofcPrim(primAtan2Float)},
  289.   {"primExpFloat",    1, GofcPrim(primExpFloat)},
  290.   {"primLogFloat",    1, GofcPrim(primLogFloat)},
  291.   {"primLog10Float",    1, GofcPrim(primLog10Float)},
  292.   {"primSqrtFloat",    1, GofcPrim(primSqrtFloat)},
  293.   {"primFloatToInt",    1, GofcPrim(primFloatToInt)},
  294.  
  295.   #if HAS_HYPERBOLICS
  296.   /* We might as well have the Hyperbolic functions -- KH */
  297.   {"primSinhFloat",    1, GofcPrim(primSinhFloat)},
  298.   {"primCoshFloat",    1, GofcPrim(primCoshFloat)},
  299.   {"primTanhFloat",    1, GofcPrim(primTanhFloat)},
  300.   {"primAsinhFloat",    1, GofcPrim(primAsinhFloat)},
  301.   {"primAcoshFloat",    1, GofcPrim(primAcoshFloat)},
  302.   {"primAtanhFloat",    1, GofcPrim(primAtanhFloat)},
  303.   #endif
  304.   #endif
  305.   
  306.   {"primIntToChar",    1, GofcPrim(primIntToChar)},
  307.   {"primCharToInt",    1, GofcPrim(primCharToInt)},
  308.   {"primIntToFloat",    1, GofcPrim(primIntToFloat)},
  309.   
  310.   {"primEqInt",        2, GofcPrim(primEqInt)},
  311.   {"primLeInt",        2, GofcPrim(primLeInt)},
  312.   {"primEqChar",    2, GofcPrim(primEqChar)},
  313.   {"primLeChar",    2, GofcPrim(primLeChar)},
  314.   {"primEqFloat",    2, GofcPrim(primEqFloat)},
  315.   {"primLeFloat",    2, GofcPrim(primLeFloat)},
  316.   
  317.   {"primGenericEq",    2, GofcPrim(primGenericEq)},
  318.   {"primGenericNe",    2, GofcPrim(primGenericNe)},
  319.   {"primGenericGt",    2, GofcPrim(primGenericGt)},
  320.   {"primGenericLe",    2, GofcPrim(primGenericLe)},
  321.   {"primGenericGe",    2, GofcPrim(primGenericGe)},
  322.   {"primGenericLt",    2, GofcPrim(primGenericLt)},
  323.   
  324.   /* C Monad primitives for the Mac -- Gofc versions not yet provided. */
  325.   #if MAC
  326.   {"primUnitIO",          1, NoGofcPrim(primUnitIO)},
  327.   {"primCUnitIO",         2, NoGofcPrim(primCUnitIO)},
  328.   {"primBindIO",          2, NoGofcPrim(primBindIO)},
  329.   {"primCBindIO",         3, NoGofcPrim(primCBindIO)},
  330.   {"primCCBindIO",        2, NoGofcPrim(primCCBindIO)},
  331.  
  332.   {"primTrap",            3, NoGofcPrim(primTrap)},
  333.   {"primTrapReg",         7, NoGofcPrim(primTrapReg)},
  334.   {"primAssign",          2, NoGofcPrim(primAssign)},
  335.   {"primAssignS",         2, NoGofcPrim(primAssignS)},
  336.   {"primAssignC",         2, NoGofcPrim(primAssignC)},
  337.   {"primAssignBlock",     2, NoGofcPrim(primAssignBlock)},
  338.   {"primMalloc",          1, NoGofcPrim(primMalloc)},
  339.   {"primFree",            1, NoGofcPrim(primFree)},
  340.   {"primDeref",           1, NoGofcPrim(primDeref)},
  341.   {"primSeq",             2, NoGofcPrim(primSeq)},
  342.   {"primTrace",           2, NoGofcPrim(primTrace)},
  343.  
  344.   /* ToolBox calls coded for speed */
  345.   {"primLineTo",          2, NoGofcPrim(primLineTo)},
  346.   {"primMoveTo",          2, NoGofcPrim(primMoveTo)},
  347.   {"primButton",          1, NoGofcPrim(primButton)},
  348.   {"primGetMouse",        1, NoGofcPrim(primGetMouse)},
  349.  
  350.   /* Event handling variations on standard code */
  351.   {"primGetNextEvent",    1, NoGofcPrim(primGetNextEvt)},
  352.   {"primEventAvail",      1, NoGofcPrim(primEvtAvail)},
  353.  
  354.   /* Prim */
  355.   {"primCreateCallback",  2, NoGofcPrim(primCreateCallback)},
  356.   {"primDisposeCallback", 1, NoGofcPrim(primDisposeCallback)},
  357.   #endif
  358.  
  359.   #if BIT_OPERATIONS
  360.   {"primBAnd",        2, GofcPrim(primBAnd)},
  361.   {"primBOr",         2, GofcPrim(primBOr)},
  362.   {"primBComp",       1, GofcPrim(primBComp)},
  363.   {"primBASL",        2, GofcPrim(primBASL)},
  364.   {"primBASR",        2, GofcPrim(primBASR)},
  365.   {"primBTst",        2, GofcPrim(primBTst)},
  366.   {"primBSet",        2, GofcPrim(primBSet)},
  367.   {"primBClr",        2, GofcPrim(primBClr)},
  368.   {"primBLSet",       1, GofcPrim(primBLSet)},
  369.   {"primBHSet",       1, GofcPrim(primBHSet)},
  370.   #endif
  371.  
  372.   {"primPrint",        3, NoGofcPrim(primPrint)},
  373.   {"primShowsInt",    3, GofcPrim(primPrint)},
  374.   {"primShowsFloat",    3, GofcPrim(primPrint)},
  375.   
  376.   {"primStrict",    2, GofcPrim(primStrict)},
  377.   
  378.   {"primFopen",        3, GofcPrim(primFopen)},
  379.  
  380.   #ifdef LAMBDAVAR
  381.   {"primLvReturn",    2, NoGofcPrim(primLvReturn)},
  382.   {"primLvPure",    1, NoGofcPrim(primLvPure)},
  383.   {"primLvRead",    3, NoGofcPrim(primLvRead)},
  384.   {"primLvBind",    3, NoGofcPrim(primLvBind)},
  385.   {"primLvVar",        2, NoGofcPrim(primLvVar)},
  386.   {"primLvNewvar",    1, NoGofcPrim(primLvNewvar)},
  387.   {"primLvAssign",    3, NoGofcPrim(primLvAssign)},
  388.   {"primLvVarEq",    2, NoGofcPrim(primLvVarEq)},
  389.   {"primLvUnbound",    0, NoGofcPrim(primFail)},
  390.   {"primLvGetch",    1, NoGofcPrim(primLvGetch)},
  391.   {"primLvPutchar",    2, NoGofcPrim(primLvPutchar)},
  392.   {"primLvSystem",    2, NoGofcPrim(primLvSystem)},
  393.   #endif
  394.   
  395. #ifdef LAMBDANU
  396.   {"primLnReturn",    2, NoGofcPrim(primLnReturn)},
  397.   {"primLnBind",    3, NoGofcPrim(primLnBind)},
  398.   {"primLnFlip",    3, NoGofcPrim(primLnFlip)},
  399.   {"primLnNew",        1, NoGofcPrim(primLnNew)},
  400.   {"primLnAssign",    3, NoGofcPrim(primLnAssign)},
  401.   {"primLnRead",    3, NoGofcPrim(primLnRead)},
  402.   {"primLnIo",        2, NoGofcPrim(primLnIo)},
  403.   {"primLnBegin",    1, NoGofcPrim(primLnBegin)},
  404.   {"primLnTagEq",    2, NoGofcPrim(primLnTagEq)},
  405.   {"primLnGetch",    1, NoGofcPrim(primLnGetch)},
  406.   {"primLnPutchar",    2, NoGofcPrim(primLnPutchar)},
  407.   {"primLnSystem",    2, NoGofcPrim(primLnSystem)},
  408.   {"primLnUnbound",    0, NoGofcPrim(primFail)},
  409.   {"primLnNocont",    0, NoGofcPrim(primFail)},
  410.   {"primLnDone",    1, NoGofcPrim(primLnDone)},
  411. #endif
  412.  
  413.   {0,            0, 0}
  414. };
  415.  
  416. #if 0
  417. dotrace(s,e)
  418. String s;
  419. Cell e;
  420. {
  421.   fprintf(stderr,"%s",s);
  422.   printExp(stderr,e);
  423.   fputc('\n',stderr);
  424. }
  425. #else
  426. #define dotrace(s,e)
  427. #endif
  428.  
  429. /* --------------------------------------------------------------------------
  430.  * Primitive functions:
  431.  * ------------------------------------------------------------------------*/
  432.  
  433. #if PRIMITIVES_CODE
  434. primFun(primFatbar) {            /* Fatbar primitive           */
  435.     Cell l    = primArg(2);        /* _FAIL [] r = r           */
  436.     Cell r    = primArg(1);        /* l     [] r = l  -- otherwise       */
  437.     Cell temp = evalWithNoError(l);
  438.     if (nonNull(temp))
  439.     if (temp==nameFail)
  440.         updateRoot(r);
  441.     else {
  442.         updateRoot(temp);
  443.         cantReduce();
  444.     }
  445.     else
  446.     updateRoot(l);
  447. }
  448.  
  449. primFun(primFail) {               /* Failure primitive           */
  450.     cantReduce();
  451. }
  452.  
  453. primFun(primSel) {               /* Component selection           */
  454.     Cell c = primArg(3);           /* _sel c e n   return nth component*/
  455.     Cell e = primArg(2);           /*           in expression e       */
  456.     Cell n = intOf(primArg(1));        /*           built using cfun c  */
  457.  
  458.     eval(e);
  459.     if (whnfHead==c &&    ((isName(whnfHead) && name(whnfHead).arity==whnfArgs)
  460.               || (isTuple(whnfHead) && tupleOf(whnfHead)==whnfArgs)))
  461.     updateRoot(pushed(n-1));
  462.     else
  463.     cantReduce();
  464. }
  465.  
  466. primFun(primIf) {               /* Conditional primitive        */
  467.     eval(primArg(3));
  468.     if (whnfHead==nameTrue)
  469.     updateRoot(primArg(2));
  470.     else
  471.     updateRoot(primArg(1));
  472. }
  473.  
  474. primFun(primStrict) {               /* Strict application primitive       */
  475.     eval(primArg(1));               /* evaluate 2nd argument        */
  476.     updapRoot(primArg(2),primArg(1));  /* and apply 1st argument to result */
  477. }
  478.  
  479. /* --------------------------------------------------------------------------
  480.  * Integer arithmetic primitives:
  481.  * ------------------------------------------------------------------------*/
  482.  
  483. primFun(primPlusInt) {               /* Integer addition primitive       */
  484.     Int x;
  485.     eval(primArg(2));
  486.     x = whnfInt;
  487.     eval(primArg(1));
  488.     updateRoot(mkInt(x+whnfInt));
  489. }
  490.  
  491. primFun(primMinusInt) {            /* Integer subtraction primitive    */
  492.     Int x;
  493.     eval(primArg(2));
  494.     x = whnfInt;
  495.     eval(primArg(1));
  496.     updateRoot(mkInt(x-whnfInt));
  497. }
  498.  
  499. primFun(primMulInt) {               /* Integer multiplication primitive */
  500.     Int x;
  501.     eval(primArg(2));
  502.     x = whnfInt;
  503.     eval(primArg(1));
  504.     updateRoot(mkInt(x*whnfInt));
  505. }
  506.  
  507. primFun(primQuotInt) {            /* Integer division primitive       */
  508.     Int x;                /* truncated towards zero       */
  509.     eval(primArg(2));
  510.     x = whnfInt;
  511.     eval(primArg(1));
  512.  
  513.     if (whnfInt==0)
  514.     cantReduce();
  515.  
  516.     updateRoot(mkInt(x/whnfInt));
  517. }
  518.  
  519. primFun(primDivInt) {            /* Integer division primitive       */
  520.     Int x,r;                /* truncated towards -ve infinity  */
  521.     eval(primArg(2));
  522.     x = whnfInt;
  523.     eval(primArg(1));
  524.  
  525.     if (whnfInt==0)
  526.     cantReduce();
  527.     r = x%whnfInt;
  528.     x = x/whnfInt;
  529.     if ((whnfInt<0 && r>0) || (whnfInt>0 && r<0))
  530.     x--;
  531.     updateRoot(mkInt(x));
  532. }
  533.  
  534. /*
  535.     Isn't x%y undefined if either x or y is negative,
  536.     at least in original K&R C?  
  537.     These two definitions may only work for an ANSI C compiler,
  538.     in fact they seem to have broken for MPW C in the past...
  539.  
  540.     KH
  541. */
  542.  
  543. primFun(primModInt) {               /* Integer modulo primitive       */
  544.     Int x,y;
  545.     eval(primArg(2));
  546.     x = whnfInt;
  547.     eval(primArg(1));
  548.     if (whnfInt==0)
  549.     cantReduce();
  550.     y = x%whnfInt;               /* "... the modulo having the sign  */
  551.     if ((y<0 && whnfInt>0) ||           /*           of the divisor ..." */
  552.     (y>0 && whnfInt<0))           /* See definition on p.91 of Haskell*/
  553.     updateRoot(mkInt(y+whnfInt));  /* report...               */
  554.     else
  555.     updateRoot(mkInt(y));
  556. }
  557.  
  558. primFun(primRemInt) {               /* Integer remainder primitive       */
  559.     Int x;
  560.     eval(primArg(2));               /* div and rem satisfy:           */
  561.     x = whnfInt;               /* (x `div` y)*y + (x `rem` y) == x */
  562.     eval(primArg(1));               /* which is exactly the property    */
  563.     if (whnfInt==0)               /* described in K&R 2:           */
  564.     cantReduce();               /*      (a/b)*b + a%b == a       */
  565.     updateRoot(mkInt(x%whnfInt));
  566. }
  567.  
  568. primFun(primNegInt) {               /* Integer negation primitive       */
  569.     eval(primArg(1));
  570.     updateRoot(mkInt(-whnfInt));
  571. }
  572.  
  573. /* --------------------------------------------------------------------------
  574.  * Coercion primitives:
  575.  * ------------------------------------------------------------------------*/
  576.  
  577. primFun(primCharToInt) {           /* Character to integer primitive   */
  578.     eval(primArg(1));
  579.     updateRoot(mkInt(charOf(whnfHead)));
  580. }
  581.  
  582. primFun(primIntToChar) {           /* Integer to character primitive   */
  583.     eval(primArg(1));
  584.     if (whnfInt<0  || whnfInt>MAXCHARVAL)
  585.     cantReduce();
  586.     updateRoot(mkChar(whnfInt));
  587. }
  588.  
  589. #if BIT_OPERATIONS
  590. primFun(primBAnd) {            /* Bytewise And primitive       */
  591.     unsigned x;
  592.     eval(primArg(2));
  593.     x = whnfInt;
  594.     eval(primArg(1));
  595.  
  596.     updateRoot(mkInt((unsigned)(x&(unsigned)whnfInt)));
  597. }
  598.  
  599. primFun(primBOr) {            /* Bytewise Or primitive       */
  600.     unsigned x;
  601.     eval(primArg(2));
  602.     x = whnfInt;
  603.     eval(primArg(1));
  604.  
  605.     updateRoot(mkInt((unsigned)(x|(unsigned)whnfInt)));
  606. }
  607.  
  608. primFun(primBComp) {            /* Bytewise Complement primitive   */
  609.     eval(primArg(1));
  610.  
  611.     updateRoot(mkInt((unsigned)(~(unsigned)whnfInt)));
  612. }
  613.  
  614. primFun(primBASL) {            /* Arithmetic Shift Left primitive   */
  615.     unsigned x;
  616.     eval(primArg(2));
  617.     x = whnfInt;
  618.     eval(primArg(1));
  619.  
  620.     updateRoot(mkInt((unsigned)(x<<(unsigned)whnfInt)));
  621. }
  622.  
  623. primFun(primBASR) {            /* Arithmetic Shift Right primitive   */
  624.     unsigned x;                /* To avoid sign-extension          */
  625.     eval(primArg(2));
  626.     x = whnfInt;
  627.     eval(primArg(1));
  628.  
  629.     updateRoot(mkInt((unsigned)(x>>(unsigned)whnfInt)));
  630. }
  631.  
  632. primFun(primBTst) {            /* Bit Testing primitive       */
  633.     unsigned x, b;
  634.     eval(primArg(2));
  635.     x = whnfInt;
  636.     eval(primArg(1));
  637.  
  638.     b = 1 << (whnfInt-1);
  639.     updateRoot((x&b)==b ? nameTrue: nameFalse);
  640. }
  641.  
  642. primFun(primBSet) {            /* Bit Setting primitive       */
  643.     Int x;
  644.     Int b;
  645.     eval(primArg(2));
  646.     x = whnfInt;
  647.     eval(primArg(1));
  648.  
  649.     b = 1 << (whnfInt-1);
  650.     updateRoot(mkInt(x|b));
  651. }
  652.  
  653. primFun(primBClr) {            /* Bit Clearing primitive       */
  654.     Int x;
  655.     Int b;
  656.     eval(primArg(2));
  657.     x = whnfInt;
  658.     eval(primArg(1));
  659.  
  660.     b = 1 << (whnfInt-1);
  661.     updateRoot(mkInt(x&~b));
  662. }
  663.  
  664.  
  665. primFun(primBLSet) {            /* Locate least set bit       */
  666.     Int b;
  667.     unsigned mask;
  668.     eval(primArg(1));
  669.     
  670.     for(b=1,mask=1;mask!=0;++b,mask<<=1)
  671.       if(whnfInt&mask)
  672.         break;
  673.  
  674.     if(mask==0)
  675.       b=0;
  676.     updateRoot(mkInt(b));
  677. }
  678.  
  679. /*
  680.     This algorithm works from the lowest bit, so that it
  681.     works on ANY word-size machine without modification.
  682.     This makes it rather inefficient.  Better suggestions
  683.     are welcome!  KH
  684. */
  685.  
  686. primFun(primBHSet) {            /* Locate highest set bit       */
  687.     Int b;
  688.     Int highest;
  689.     unsigned mask;
  690.  
  691.     eval(primArg(1));
  692.     
  693.     for(b=highest=1,mask=1;mask!=0;++b,mask<<=1)
  694.       if(whnfInt&mask)
  695.         highest=b;
  696.  
  697.     updateRoot(mkInt(highest));
  698. }
  699.  
  700. #endif
  701.  
  702. #if MPW
  703. /*
  704.    These hacks are needed to get around the garbage collector
  705.    which interferes with float passing conventions on the Mac.
  706.    See machine.c for the full details -- KH
  707. */
  708.  
  709. union {Float c; float f;} fi, gi;
  710.  
  711. UPDFLOAT(root,result,f)
  712. Cell root, result;
  713. float f;
  714. {
  715.     fi.f = f;
  716.     snd(result) = fi.c;
  717.     updateRoot(result);
  718. }
  719.  
  720. Int FLZERO()
  721. {
  722.     fi.c = whnfFloat;
  723.     return(fi.f==0.0);
  724. }
  725.  
  726. Int EQFLOAT(x)
  727. Float x;
  728. {
  729.    fi.c = whnfFloat;
  730.    gi.c = x;
  731.    return(gi.f==fi.f);
  732. }
  733.  
  734. Int LEFLOAT(x)
  735. Float x;
  736. {
  737.    fi.c = whnfFloat;
  738.    gi.c = x;
  739.    return(gi.f<=fi.f);
  740. }
  741.  
  742. Int GTFLOAT(w)
  743. {
  744.   fi.c = whnfFloat;
  745.   gi.c = floatOf(w);
  746.   return(gi.f > fi.f);
  747. }
  748.  
  749. Int LTFLOAT(w)
  750. {
  751.   fi.c = whnfFloat;
  752.   gi.c = floatOf(w);
  753.   return(gi.f < fi.f);
  754. }
  755.  
  756. #else
  757. #define UPDFLOAT(r,w)    updateRoot(mkFloat((Float)(w)))
  758. #define GTFLOAT(w)    floatOf(w) > whnfFloat
  759. #define LTFLOAT(w)    floatOf(w) < whnfFloat
  760. #define FNEGATIVE(w)    floatOf(w) < 0.0
  761. #endif
  762.  
  763.  
  764. #if !MPW
  765. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  766.     eval(primArg(1));
  767.     updateRoot(mkFloat((Float)(whnfInt)));
  768. }
  769.  
  770. /* --------------------------------------------------------------------------
  771.  * Float arithmetic primitives:
  772.  * ------------------------------------------------------------------------*/
  773.  
  774. primFun(primPlusFloat) {           /* Float addition primitive       */
  775.     Float x;
  776.     eval(primArg(2));
  777.     x = whnfFloat;
  778.     eval(primArg(1));
  779.     updateRoot(mkFloat(x+whnfFloat));
  780. }
  781.  
  782. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  783.     Float x;
  784.     eval(primArg(2));
  785.     x = whnfFloat;
  786.     eval(primArg(1));
  787.     updateRoot(mkFloat(x-whnfFloat));
  788. }
  789.  
  790. primFun(primMulFloat) {               /* Float multiplication primitive   */
  791.     Float x;
  792.     eval(primArg(2));
  793.     x = whnfFloat;
  794.     eval(primArg(1));
  795.     updateRoot(mkFloat(x*whnfFloat));
  796. }
  797.  
  798. primFun(primDivFloat) {               /* Float division primitive       */
  799.     Float x;
  800.     eval(primArg(2));
  801.     x = whnfFloat;
  802.     eval(primArg(1));
  803.     if (whnfFloat==0)
  804.     cantReduce();
  805.     updateRoot(mkFloat(x/whnfFloat));
  806. }
  807.  
  808. primFun(primNegFloat) {               /* Float negation primitive       */
  809.     eval(primArg(1));
  810.     updateRoot(mkFloat(-whnfFloat));
  811. }
  812.  
  813. #if HAS_FLOATS
  814. primFun(primSinFloat) {            /* Float sin (trig) primitive       */
  815.     eval(primArg(1));
  816.     updateRoot(mkFloat(sin(whnfFloat)));
  817. }
  818.  
  819. primFun(primCosFloat) {            /* Float cos (trig) primitive       */
  820.     eval(primArg(1));
  821.     updateRoot(mkFloat(cos(whnfFloat)));
  822. }
  823.  
  824. primFun(primTanFloat) {            /* Float tan (trig) primitive       */
  825.     eval(primArg(1));
  826.     updateRoot(mkFloat(tan(whnfFloat)));
  827. }
  828.  
  829. primFun(primAsinFloat) {        /* Float arc sin (trig) primitive  */
  830.     eval(primArg(1));
  831.     updateRoot(mkFloat(asin(whnfFloat)));
  832. }
  833.  
  834. primFun(primAcosFloat) {        /* Float arc cos (trig) primitive  */
  835.     eval(primArg(1));
  836.     updateRoot(mkFloat(acos(whnfFloat)));
  837. }
  838.  
  839. primFun(primAtanFloat) {        /* Float arc tan (trig) primitive  */
  840.     eval(primArg(1));
  841.     updateRoot(mkFloat(atan(whnfFloat)));
  842. }
  843.  
  844. #if HAS_HYPERBOLICS
  845. primFun(primSinhFloat) {            /* Hyperbolic Float sin (trig) primitive       */
  846.     eval(primArg(1));
  847.     updateRoot(mkFloat(sinh(whnfFloat)));
  848. }
  849.  
  850. primFun(primCoshFloat) {            /* Hyperbolic Float cos (trig) primitive       */
  851.     eval(primArg(1));
  852.     updateRoot(mkFloat(cosh(whnfFloat)));
  853. }
  854.  
  855. primFun(primTanhFloat) {            /* Hyperbolic Float tan (trig) primitive       */
  856.     eval(primArg(1));
  857.     updateRoot(mkFloat(tanh(whnfFloat)));
  858. }
  859.  
  860. primFun(primAsinhFloat) {        /* Hyperbolic Float arc sin (trig) primitive  */
  861.     eval(primArg(1));
  862.     updateRoot(mkFloat(asinh(whnfFloat)));
  863. }
  864.  
  865. primFun(primAcoshFloat) {        /* Hyperbolic Float arc cos (trig) primitive  */
  866.     eval(primArg(1));
  867.     updateRoot(mkFloat(acosh(whnfFloat)));
  868. }
  869.  
  870. primFun(primAtanhFloat) {        /* Hyperbolic Float arc tan (trig) primitive  */
  871.     eval(primArg(1));
  872.     updateRoot(mkFloat(atanh(whnfFloat)));
  873. }
  874. #endif
  875.  
  876. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  877.     Float t;                /*          (trig) primitive  */
  878.     eval(primArg(2));
  879.     t = whnfFloat;
  880.     eval(primArg(1));
  881.     updateRoot(mkFloat(atan2(t,whnfFloat)));
  882. }
  883.  
  884. primFun(primExpFloat) {            /* Float exponential primitive       */
  885.     eval(primArg(1));
  886.     updateRoot(mkFloat(exp(whnfFloat)));
  887. }
  888.  
  889. primFun(primLogFloat) {            /* Float logarithm primitive       */
  890.     eval(primArg(1));
  891.     if (whnfFloat<=0)
  892.     cantReduce();
  893.     updateRoot(mkFloat(log(whnfFloat)));
  894. }
  895.  
  896. /* ??why is this primitive?? KH: log10(x) = log(x)/log(10) */
  897. primFun(primLog10Float) {        /* Float logarithm (base 10) prim  */
  898.     eval(primArg(1));
  899.     if (whnfFloat<=0)
  900.     cantReduce();
  901.     updateRoot(mkFloat(log10(whnfFloat)));
  902. }
  903.  
  904. primFun(primSqrtFloat) {        /* Float square root primitive       */
  905.     eval(primArg(1));
  906.     if (whnfFloat<0)
  907.     cantReduce();
  908.     updateRoot(mkFloat(sqrt(whnfFloat)));
  909. }
  910.  
  911. primFun(primFloatToInt) {        /* Adhoc Float --> Int conversion  */
  912.     eval(primArg(1));
  913.  
  914. /*
  915.    My version is probably better for negative floats 
  916.    -- assuming you want truncation...  KH
  917. */
  918. #if 0
  919.     updateRoot(mkInt((Int)(whnfFloat)));
  920. #else
  921.     {
  922.       Int ftoi = (Int) whnfFloat;
  923.       updateRoot(mkInt(whnfFloat>=0.0? ftoi:
  924.                        (Float) ftoi == whnfFloat? ftoi:
  925.                    (ftoi-1)));
  926.     }
  927. #endif
  928. }
  929. #endif
  930.  
  931.  
  932. #else    /* !MPW */
  933.  
  934. #pragma segment Builtin2
  935.  
  936. #define createFloatResult()    mkFloat(0)
  937.  
  938. Boolean FNEGATIVE(x)
  939. Float x;
  940. {
  941.     fi.c = x;
  942.     return(fi.f<0.0);
  943. }
  944.  
  945.  
  946. ITOF(root,result,w)
  947. Cell root, result;
  948. Int w;
  949. {
  950.     fi.f = (float) w;
  951.     UPDFLOAT(root,result,fi.f);
  952. }
  953.  
  954. FTOI(root)
  955. Cell root;
  956. {
  957.     fi.c = whnfFloat;
  958.     updateRoot(mkInt(fi.f>=0.0?(int)fi.f:
  959.                      (float)((int)(fi.f))==fi.f?(int)fi.f:
  960.                   ((int)fi.f)-1));
  961. }
  962.  
  963. ADDFLOAT(root,result,x)
  964. Cell root,result;
  965. Float x;
  966. {
  967.    fi.c = x;
  968.    gi.c = whnfFloat;
  969.    UPDFLOAT(root,result,fi.f+gi.f);
  970. }
  971.  
  972. SUBFLOAT(root,result,x)
  973. Cell root,result;
  974. Float x;
  975. {
  976.    fi.c = x;
  977.    gi.c = whnfFloat;
  978.    UPDFLOAT(root,result,fi.f-gi.f);
  979. }
  980.  
  981. MULFLOAT(root,result,x)
  982. Cell root,result;
  983. Float x;
  984. {
  985.    fi.c = x;
  986.    gi.c = whnfFloat;
  987.    UPDFLOAT(root,result,fi.f*gi.f);
  988. }
  989.  
  990. DIVFLOAT(root,result,x)
  991. Cell root, result;
  992. Float x;
  993. {
  994.    fi.c = x;
  995.    gi.c = whnfFloat;
  996.    UPDFLOAT(root,result,fi.f/gi.f);
  997. }
  998.  
  999. NEGFLOAT(root,result)
  1000. Cell root, result;
  1001. {
  1002.    gi.c = whnfFloat;
  1003.    UPDFLOAT(root,result,-gi.f);
  1004. }
  1005.  
  1006. SQRT(root,result)
  1007. Cell root, result;
  1008. {
  1009.    gi.c = whnfFloat;
  1010.    UPDFLOAT(root,result,sqrt(gi.f));
  1011. }
  1012.  
  1013. LOG(root,result)
  1014. Cell root, result;
  1015. {
  1016.    gi.c = whnfFloat;
  1017.    UPDFLOAT(root,result,log(gi.f));
  1018. }
  1019.  
  1020. LOG10(root,result)
  1021. Cell root, result;
  1022. {
  1023.    gi.c = whnfFloat;
  1024.    UPDFLOAT(root,result,log10(gi.f));
  1025. }
  1026.  
  1027. EXP(root,result)
  1028. Cell root, result;
  1029. {
  1030.    gi.c = whnfFloat;
  1031.    UPDFLOAT(root,result,exp(gi.f));
  1032. }
  1033.  
  1034. SIN(root,result)
  1035. Cell root,result;
  1036. {
  1037.    gi.c = whnfFloat;
  1038.    UPDFLOAT(root,result,sin(gi.f));
  1039. }
  1040.  
  1041. COS(root,result)
  1042. Cell root,result;
  1043. {
  1044.    gi.c = whnfFloat;
  1045.    UPDFLOAT(root,result,cos(gi.f));
  1046. }
  1047.  
  1048. TAN(root,result)
  1049. Cell root,result;
  1050. {
  1051.    gi.c = whnfFloat;
  1052.    UPDFLOAT(root,result,tan(gi.f));
  1053. }
  1054.  
  1055. ASIN(root,result)
  1056. Cell root,result;
  1057. {
  1058.    gi.c = whnfFloat;
  1059.    UPDFLOAT(root,result,asin(gi.f));
  1060. }
  1061.  
  1062. ACOS(root,result)
  1063. Cell root,result;
  1064. {
  1065.    gi.c = whnfFloat;
  1066.    UPDFLOAT(root,result,acos(gi.f));
  1067. }
  1068.  
  1069. ATAN(root,result)
  1070. Cell root,result;
  1071. {
  1072.    gi.c = whnfFloat;
  1073.    UPDFLOAT(root,result,atan(gi.f));
  1074. }
  1075.  
  1076. ATAN2(root,result,x)
  1077. Cell root,result;
  1078. Float x;
  1079. {
  1080.    fi.c = x;
  1081.    gi.c = whnfFloat;
  1082.    UPDFLOAT(root,result,atan2(fi.f,gi.f));
  1083. }
  1084.  
  1085. SINH(root,result)
  1086. Cell root,result;
  1087. {
  1088.    gi.c = whnfFloat;
  1089.    UPDFLOAT(root,result,sinh(gi.f));
  1090. }
  1091.  
  1092. COSH(root,result)
  1093. Cell root,result;
  1094. {
  1095.    gi.c = whnfFloat;
  1096.    UPDFLOAT(root,result,cosh(gi.f));
  1097. }
  1098.  
  1099. TANH(root,result)
  1100. Cell root,result;
  1101. {
  1102.    gi.c = whnfFloat;
  1103.    UPDFLOAT(root,result,tanh(gi.f));
  1104. }
  1105.  
  1106. ASINH(root,result)
  1107. Cell root,result;
  1108. {
  1109. #if 1
  1110.    updapRoot(nameAsinh,whnfFloat);
  1111. #else
  1112.    gi.c = whnfFloat;
  1113.    UPDFLOAT(root,result,asinh(gi.f));
  1114. #endif
  1115. }
  1116.  
  1117. ACOSH(root,result)
  1118. Cell root,result;
  1119. {
  1120. #if 1
  1121.    updapRoot(nameAcosh,whnfFloat);
  1122. #else
  1123.    gi.c = whnfFloat;
  1124.    UPDFLOAT(root,result,acosh(gi.f));
  1125. #endif
  1126. }
  1127.  
  1128. ATANH(root,result)
  1129. Cell root,result;
  1130. {
  1131. #if 1
  1132.    updapRoot(nameAtanh,whnfFloat);
  1133. #else
  1134.    gi.c = whnfFloat;
  1135.    UPDFLOAT(root,result,atanh(gi.f));
  1136. #endif
  1137. }
  1138.  
  1139. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  1140.     Float result = 0;
  1141.     eval(primArg(1));
  1142.     result = createFloatResult();
  1143.     ITOF(root,result,whnfInt);
  1144. }
  1145.  
  1146. primFun(primPlusFloat) {           /* Float addition primitive       */
  1147.     Float x, result = 0;
  1148.     eval(primArg(2));
  1149.     x = whnfFloat;
  1150.     eval(primArg(1));
  1151.     result = createFloatResult();
  1152.     ADDFLOAT(root,result,x);
  1153. }
  1154.  
  1155. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  1156.     Float x, result = 0;
  1157.     eval(primArg(2));
  1158.     x = whnfFloat;
  1159.     eval(primArg(1));
  1160.     result = createFloatResult();
  1161.     SUBFLOAT(root,result,x);
  1162. }
  1163.  
  1164. primFun(primMulFloat) {               /* Float multiplication primitive   */
  1165.     Float x, result = 0;
  1166.     eval(primArg(2));
  1167.     x = whnfFloat;
  1168.     eval(primArg(1));
  1169.     result = createFloatResult();
  1170.     MULFLOAT(root,result,x);
  1171. }
  1172.  
  1173.  
  1174. primFun(primDivFloat) {               /* Float division primitive       */
  1175.     Float x, result = 0;
  1176.     eval(primArg(2));
  1177.     x = whnfFloat;
  1178.     eval(primArg(1));
  1179.     if (FLZERO())
  1180.     cantReduce();
  1181.     result = createFloatResult();
  1182.     DIVFLOAT(root,result,x);
  1183. }
  1184.  
  1185. primFun(primNegFloat) {               /* Float negation primitive       */
  1186.     Float result = 0;
  1187.     eval(primArg(1));
  1188.     result = createFloatResult();
  1189.     NEGFLOAT(root,result);
  1190. }
  1191.  
  1192. primFun(primFloatToInt) {        /* Float Truncation primitive       */
  1193.     eval(primArg(1));
  1194.     FTOI(root);
  1195. }
  1196.  
  1197. primFun(primSqrtFloat) {        /* Square Root primitive       */
  1198.     Float result = 0;
  1199.     eval(primArg(1));
  1200.     result = createFloatResult();
  1201.     SQRT(root,result);
  1202. }
  1203.  
  1204. primFun(primLogFloat) {            /* Natural Logarithm primitive       */
  1205.     Float result = 0;
  1206.     eval(primArg(1));
  1207.     result = createFloatResult();
  1208.     LOG(root,result);
  1209. }
  1210.  
  1211. primFun(primLog10Float) {        /* Logarithm (base 10) primitive       */
  1212.     Float result = 0;
  1213.     eval(primArg(1));
  1214.     result = createFloatResult();
  1215.     LOG10(root,result);
  1216. }
  1217.  
  1218. primFun(primExpFloat) {            /* Inverse Logarithm primitive       */
  1219.     Float result = 0;
  1220.     eval(primArg(1));
  1221.     result = createFloatResult();
  1222.     EXP(root,result);
  1223. }
  1224.  
  1225. primFun(primSinFloat) {            /* Sine primitive       */
  1226.     Float result = 0;
  1227.     eval(primArg(1));
  1228.     result = createFloatResult();
  1229.     SIN(root,result);
  1230. }
  1231.  
  1232. primFun(primCosFloat) {            /* Cosine primitive       */
  1233.     Float result = 0;
  1234.     eval(primArg(1));
  1235.     result = createFloatResult();
  1236.     COS(root,result);
  1237. }
  1238.  
  1239. primFun(primTanFloat) {            /* Tangent primitive       */
  1240.     Float result = 0;
  1241.     eval(primArg(1));
  1242.     result = createFloatResult();
  1243.     TAN(root,result);
  1244. }
  1245.  
  1246. primFun(primAsinFloat) {        /* ArcSin primitive       */
  1247.     Float result = 0;
  1248.     eval(primArg(1));
  1249.     result = createFloatResult();
  1250.     ASIN(root,result);
  1251. }
  1252.  
  1253. primFun(primAcosFloat) {        /* ArcCos primitive       */
  1254.     Float result = 0;
  1255.     eval(primArg(1));
  1256.     result = createFloatResult();
  1257.     ACOS(root,result);
  1258. }
  1259.  
  1260. primFun(primAtanFloat) {        /* ArcTangent primitive       */
  1261.     Float result = 0;
  1262.     eval(primArg(1));
  1263.     result = createFloatResult();
  1264.     ATAN(root,result);
  1265. }
  1266.  
  1267. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  1268.     Float x, result = 0;
  1269.     eval(primArg(2));
  1270.     x = whnfFloat;
  1271.     eval(primArg(1));
  1272.     result = createFloatResult();
  1273.     ATAN2(root,result,x);
  1274. }
  1275.  
  1276. #if HAS_HYPERBOLICS
  1277. primFun(primSinhFloat) {        /* Hyperbolic Sine primitive       */
  1278.     Float result = 0;
  1279.     eval(primArg(1));
  1280.     result = createFloatResult();
  1281.     SINH(root,result);
  1282. }
  1283.  
  1284. primFun(primCoshFloat) {        /* Hyperbolic Cosine primitive       */
  1285.     Float result = 0;
  1286.     eval(primArg(1));
  1287.     result = createFloatResult();
  1288.     COSH(root,result);
  1289. }
  1290.  
  1291. primFun(primTanhFloat) {        /* Hyperbolic Tangent primitive       */
  1292.     Float result = 0;
  1293.     eval(primArg(1));
  1294.     result = createFloatResult();
  1295.     TANH(root,result);
  1296. }
  1297.  
  1298. primFun(primAsinhFloat) {        /* Hyperbolic ArcSin primitive       */
  1299.     Float result = 0;
  1300.     eval(primArg(1));
  1301.     result = createFloatResult();
  1302.     ASINH(root,result);
  1303. }
  1304.  
  1305. primFun(primAcoshFloat) {        /* Hyperbolic ArcCos primitive       */
  1306.     Float result = 0;
  1307.     eval(primArg(1));
  1308.     result = createFloatResult();
  1309.     ACOSH(root,result);
  1310. }
  1311.  
  1312. primFun(primAtanhFloat) {        /* Hyperbolic ArcTangent primitive       */
  1313.     Float result = 0;
  1314.     eval(primArg(1));
  1315.     result = createFloatResult();
  1316.     ATANH(root,result);
  1317. }
  1318. #endif
  1319. #endif
  1320.  
  1321.  
  1322. /* --------------------------------------------------------------------------
  1323.  * Comparison primitives:
  1324.  * ------------------------------------------------------------------------*/
  1325.  
  1326. primFun(primEqInt) {               /* Integer equality primitive       */
  1327.     Int x;
  1328.     eval(primArg(2));
  1329.     x = whnfInt;
  1330.     eval(primArg(1));
  1331.     updateRoot(x==whnfInt ? nameTrue : nameFalse);
  1332. }
  1333.  
  1334. primFun(primLeInt) {               /* Integer <= primitive           */
  1335.     Int x;
  1336.     eval(primArg(2));
  1337.     x = whnfInt;
  1338.     eval(primArg(1));
  1339.     updateRoot(x<=whnfInt ? nameTrue : nameFalse);
  1340. }
  1341.  
  1342. primFun(primEqChar) {               /* Character equality primitive       */
  1343.     Cell x;
  1344.     eval(primArg(2));
  1345.     x = whnfHead;
  1346.     eval(primArg(1));
  1347.     updateRoot(x==whnfHead ? nameTrue : nameFalse);
  1348. }
  1349.  
  1350. primFun(primLeChar) {               /* Character <= primitive       */
  1351.     Cell x;
  1352.     eval(primArg(2));
  1353.     x = whnfHead;
  1354.     eval(primArg(1));
  1355.     updateRoot(x<=whnfHead ? nameTrue : nameFalse);
  1356. }
  1357.  
  1358. #if !MPW
  1359. primFun(primEqFloat) {               /* Float equality primitive       */
  1360.     Float x;
  1361.     eval(primArg(2));
  1362.     x = whnfFloat;
  1363.     eval(primArg(1));
  1364.     updateRoot(x==whnfFloat ? nameTrue : nameFalse);
  1365. }
  1366.  
  1367. primFun(primLeFloat) {               /* Float <= primitive           */
  1368.     Float x;
  1369.     eval(primArg(2));
  1370.     x = whnfFloat;
  1371.     eval(primArg(1));
  1372.     updateRoot(x<=whnfFloat ? nameTrue : nameFalse);
  1373. }
  1374. #else    /* !MPW */
  1375. primFun(primEqFloat) {               /* Float equality primitive       */
  1376.     Float x;
  1377.     eval(primArg(2));
  1378.     x = whnfFloat;
  1379.     eval(primArg(1));
  1380.     updateRoot(EQFLOAT(x) ? nameTrue : nameFalse);
  1381. }
  1382.  
  1383. primFun(primLeFloat) {               /* Float equality primitive       */
  1384.     Float x;
  1385.     eval(primArg(2));
  1386.     x = whnfFloat;
  1387.     eval(primArg(1));
  1388.     updateRoot(LEFLOAT(x) ? nameTrue : nameFalse);
  1389. }
  1390. #endif
  1391.  
  1392.  
  1393. #if MPW
  1394. #pragma segment PrimCmp
  1395. #endif
  1396.  
  1397. /* Generic comparisons implemented using the internal primitive function:
  1398.  *
  1399.  * primCmp []            = EQ
  1400.  *         ((C xs, D ys):rs)
  1401.  *       | C < D        = LT
  1402.  *       | C == D        = primCmp (zip xs ys ++ rs)
  1403.  *       | C > D        = GT
  1404.  *       ((Int n, Int m):rs)
  1405.  *       | n < m        = LT
  1406.  *       | n == m        = primCmp rs
  1407.  *       | n > m        = GT
  1408.  *       etc ... similar for comparison of characters:
  1409.  *
  1410.  * The list argument to primCmp is represented as an `internal list';
  1411.  * i.e. no (:)/[] constructors - use internal cons and NIL instead!
  1412.  *
  1413.  * To compare two values x and y, evaluate primCmp [(x,y)] and use result.
  1414.  */
  1415.  
  1416. #define LT            1
  1417. #define EQ            2
  1418. #define GT            3
  1419. #define compResult(x) updateRoot(mkInt(x))
  1420.  
  1421. static Name namePrimCmp;
  1422.  
  1423. primFun(primCmp) {            /* generic comparison function       */
  1424.     Cell rs = primArg(1);
  1425.  
  1426.     if (isNull(rs)) {
  1427.     compResult(EQ);
  1428.     return;
  1429.     }
  1430.     else {
  1431.     Cell x = fst(hd(rs));
  1432.     Cell y = snd(hd(rs));
  1433.     Int  whnfArgs1;
  1434.     Cell whnfHead1;
  1435.  
  1436.     rs = tl(rs);
  1437.     eval(x);
  1438.     whnfArgs1 = whnfArgs;
  1439.     whnfHead1 = whnfHead;
  1440.  
  1441.     switch (whatIs(whnfHead1)) {
  1442.         case INTCELL  : if (whnfArgs==0) {        /* compare ints    */
  1443.                 eval(y);
  1444.                 if (!isInt(whnfHead) || whnfArgs!=0)
  1445.                     break;
  1446.                 if (intOf(whnfHead1) > whnfInt)
  1447.                     compResult(GT);
  1448.                 else if (intOf(whnfHead1) < whnfInt)
  1449.                     compResult(LT);
  1450.                 else
  1451.                     updapRoot(namePrimCmp,rs);
  1452.                 return;
  1453.                 }
  1454.                 break;
  1455.  
  1456.         case FLOATCELL: if (whnfArgs==0) {        /* compare floats  */
  1457.                 eval(y);
  1458.                 if (!isFloat(whnfHead) || whnfArgs!=0)
  1459.                     break;
  1460.                 if (GTFLOAT(whnfHead1))
  1461.                     compResult(GT);
  1462.                 else if (LTFLOAT(whnfHead1))
  1463.                     compResult(LT);
  1464.                 else
  1465.                     updapRoot(namePrimCmp,rs);
  1466.                 return;
  1467.                 }
  1468.                 break;
  1469.  
  1470.         case CHARCELL : if (whnfArgs==0) {        /* compare chars   */
  1471.                 eval(y);
  1472.                 if (!isChar(whnfHead) || whnfArgs!=0)
  1473.                     break;
  1474.                 if (charOf(whnfHead1) > charOf(whnfHead))
  1475.                     compResult(GT);
  1476.                 else if (charOf(whnfHead1) < charOf(whnfHead))
  1477.                     compResult(LT);
  1478.                 else
  1479.                     updapRoot(namePrimCmp,rs);
  1480.                 return;
  1481.                 }
  1482.                 break;
  1483.  
  1484.         default      : eval(y);            /* compare structs */
  1485.                 if (whnfHead1==whnfHead &&
  1486.                 whnfArgs1==whnfArgs &&
  1487.                 (whnfHead==UNIT    ||
  1488.                  isTuple(whnfHead) ||
  1489.                  (isName(whnfHead) &&
  1490.                   name(whnfHead).defn==CFUN))) {
  1491.                 while (whnfArgs1-- >0)
  1492.                     rs = cons(pair(pushed(whnfArgs+whnfArgs1),
  1493.                            pushed(whnfArgs1)),rs);
  1494.                 updapRoot(namePrimCmp,rs);
  1495.                 return;
  1496.                 }
  1497.                 if (isName(whnfHead1)        &&
  1498.                  name(whnfHead1).defn==CFUN &&
  1499.                  isName(whnfHead)        &&
  1500.                  name(whnfHead).defn==CFUN) {
  1501.                 if (name(whnfHead1).number
  1502.                         > name(whnfHead).number)
  1503.                     compResult(GT);
  1504.                 else if (name(whnfHead1).number
  1505.                         < name(whnfHead).number)
  1506.                     compResult(LT);
  1507.                 else
  1508.                     break;
  1509.                 return;
  1510.                 }
  1511.                             break;
  1512.     }
  1513.         /* we're going to fail because we can't compare x and y; modify    */
  1514.     /* the root expression so that it looks reasonable before failing  */
  1515.     /* i.e. output produced will be:  {_compare x y}           */
  1516.     updapRoot(ap(namePrimCmp,x),y);
  1517.     }
  1518.     cantReduce();
  1519. }
  1520.  
  1521. primFun(primGenericEq) {        /* Generic equality test       */
  1522.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1523.     eval(c);
  1524.     updateRoot(whnfInt==EQ ? nameTrue : nameFalse);
  1525. }
  1526.  
  1527. primFun(primGenericLe) {        /* Generic <= test           */
  1528.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1529.     eval(c);
  1530.     updateRoot(whnfInt<=EQ ? nameTrue : nameFalse);
  1531. }
  1532.  
  1533. primFun(primGenericLt) {        /* Generic < test           */
  1534.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1535.     eval(c);
  1536.     updateRoot(whnfInt<EQ ? nameTrue : nameFalse);
  1537. }
  1538.  
  1539. primFun(primGenericGe) {        /* Generic >= test           */
  1540.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1541.     eval(c);
  1542.     updateRoot(whnfInt>=EQ ? nameTrue : nameFalse);
  1543. }
  1544.  
  1545. primFun(primGenericGt) {        /* Generic > test           */
  1546.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1547.     eval(c);
  1548.     updateRoot(whnfInt>EQ ? nameTrue : nameFalse);
  1549. }
  1550.  
  1551. primFun(primGenericNe) {        /* Generic /= test           */
  1552.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1553.     eval(c);
  1554.     updateRoot(whnfInt!=EQ ? nameTrue : nameFalse);
  1555. }
  1556.  
  1557. /* --------------------------------------------------------------------------
  1558.  * Print primitives:
  1559.  * ------------------------------------------------------------------------*/
  1560.  
  1561. #if MPW
  1562. #pragma segment PrimMisc
  1563. #endif
  1564.  
  1565. static Cell consOpen,    consSpace,  consComma,    consClose;
  1566. static Cell consObrace, consCbrace, consOsq,    consCsq;
  1567. static Cell consBack,    consMinus,  consQuote,  consDQuote;
  1568.  
  1569. static Name nameLPrint, nameNLPrint;    /* list printing primitives       */
  1570. static Name nameSPrint, nameNSPrint;    /* string printing primitives       */
  1571.  
  1572. #define print(pr,d,e,ss)    ap(ap(ap(pr,mkInt(d)),e),ss)
  1573. #define lprint(pr,xs,ss)    ap(ap(pr,xs),ss)
  1574. #define printString(s,ss)   revOnto(stringOutput(s,NIL),ss)
  1575. #define printSChar(c,ss)    printString(unlexChar(c,'\"'),ss)
  1576.  
  1577. primFun(primPrint) {            /* evaluate and print term       */
  1578.     Int  d    = intOf(primArg(3));    /*    :: Int->Expr->[Char]->[Char] */
  1579.     Cell e    = primArg(2);
  1580.     Cell ss   = primArg(1);
  1581.     Cell temp = evalWithNoError(e);
  1582.     if (nonNull(temp))
  1583.     updateRoot(printBadRedex(temp,ss));
  1584.     else
  1585.     printer(root,namePrint,d,ss);
  1586. }
  1587.  
  1588. primFun(primNPrint) {            /* print term without evaluation   */
  1589.     Int    d      = intOf(primArg(3)); /*     :: Int->Expr->[Char]->[Char] */
  1590.     Cell   e      = primArg(2);
  1591.     Cell   ss      = primArg(1);
  1592.     unwind(e);
  1593.     printer(root,nameNPrint,d,ss);
  1594. }
  1595.  
  1596. static Void local printer(root,pr,d,ss)    /* Main part: primPrint/primNPrint */
  1597. StackPtr root;                /* root or print redex           */
  1598. Name     pr;                /* printer to use on components       */
  1599. Int     d;                /* precedence level           */
  1600. Cell     ss; {                /* rest of output           */
  1601.     Int  used    = 0;
  1602.     Cell output = NIL;
  1603.  
  1604.     switch(whatIs(whnfHead)) {
  1605.  
  1606.     case NAME     : {   Syntax sy = syntaxOf(name(whnfHead).text);
  1607.  
  1608.                 if (name(whnfHead).defn!=CFUN ||
  1609.                     name(whnfHead).arity>whnfArgs)
  1610.                 pr = nameNPrint;
  1611.  
  1612.                 if (whnfHead==nameCons && whnfArgs==2) {/*list */
  1613.                 if (pr==namePrint)
  1614.                     startList(root,ss);
  1615.                 else
  1616.                     startNList(root,ss);
  1617.                 return;
  1618.                 }
  1619.                 if (whnfArgs==1 && sy!=APPLIC) {      /* (e1+) */
  1620.                 used   = 1;
  1621.                 output = ap(consClose,
  1622.                       textAsOp(name(whnfHead).text,
  1623.                        ap(consSpace,
  1624.                         print(pr,FUN_PREC-1,pushed(0),
  1625.                          ap(consOpen,NIL)))));
  1626.                 }
  1627.                 else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
  1628.                 Syntax a = assocOf(sy);
  1629.                 Int    p = precOf(sy);
  1630.                 used     = 2;
  1631.                 if (whnfArgs>2 || d>p)
  1632.                      output = ap(consOpen,output);
  1633.                 output = print(pr,(a==RIGHT_ASS?p:1+p),
  1634.                           pushed(1),
  1635.                       ap(consSpace,
  1636.                        textAsOp(name(whnfHead).text,
  1637.                         ap(consSpace,
  1638.                          print(pr,(a==LEFT_ASS? p:1+p),
  1639.                           pushed(0),
  1640.                           output)))));
  1641.                 if (whnfArgs>2 || d>p)
  1642.                     output = ap(consClose,output);
  1643.                 }
  1644.                 else                  /* f ... */
  1645.                 output = textAsVar(name(whnfHead).text,NIL);
  1646.             }
  1647.             break;
  1648.  
  1649.     case INTCELL  : {   Int digit;
  1650.  
  1651.                 if (intOf(whnfHead)<0 && d>=FUN_PREC)
  1652.                 output = ap(consClose,output);
  1653.  
  1654.                 do {
  1655.                 digit = whnfInt%10;
  1656.                 if (digit<0)
  1657.                     digit= (-digit);
  1658.                 output = ap(consChar('0'+digit),output);
  1659.                 } while ((whnfInt/=10)!=0);
  1660.  
  1661.                 if (intOf(whnfHead)<0) {
  1662.                 output = ap(consMinus,output);
  1663.                 if (d>=FUN_PREC)
  1664.                     output = ap(consOpen,output);
  1665.                 }
  1666.  
  1667.                 output = rev(output);
  1668.                 pr       = nameNPrint;
  1669.             }
  1670.             break;
  1671.  
  1672.     case UNIT     : output = ap(consClose,ap(consOpen,NIL));
  1673.             pr     = nameNPrint;
  1674.             break;
  1675.  
  1676.     case TUPLE    : {   Int  tn   = tupleOf(whnfHead);
  1677.                             Cell punc = consOpen;
  1678.                 Int  i;
  1679.  
  1680.                 used      = tn<whnfArgs ? tn : whnfArgs;
  1681.                 output    = NIL;
  1682.                 for (i=0; i<used; ++i) {
  1683.                 output = print(pr,MIN_PREC,pushed(i),
  1684.                       ap(punc,
  1685.                        output));
  1686.                 punc   = consComma;
  1687.                 }
  1688.                 for (; i<tn; ++i) {
  1689.                 output = ap(punc,output);
  1690.                 punc   = consComma;
  1691.                 }
  1692.                 output = ap(consClose,output);
  1693.             }
  1694.             pr = nameNPrint;
  1695.             break;
  1696.  
  1697.     case CHARCELL : output = ap(consQuote,
  1698.                                   stringOutput(unlexChar(charOf(whnfHead),
  1699.                                                          '\''),
  1700.                    ap(consQuote,
  1701.                     output)));
  1702.             pr     = nameNPrint;
  1703.             break;
  1704.  
  1705.     case FLOATCELL:
  1706.     
  1707. /* The standard Gofer was broken here -- needs parens around negative floats...  KH */ 
  1708.             if (FNEGATIVE(whnfFloat) && d>=FUN_PREC)
  1709.                   output = ap(consOpen,output);
  1710.                     output = stringOutput(floatToString(whnfFloat),
  1711.                           output);
  1712.                 if (FNEGATIVE(whnfFloat) && d>=FUN_PREC)
  1713.                   output = ap(consClose,output);
  1714.             pr     = nameNPrint;
  1715.             break;
  1716.  
  1717.         case DICTCELL : output = stringOutput("{dict}",output);
  1718.             pr     = nameNPrint;
  1719.             break;
  1720.  
  1721.     case FILECELL : output = stringOutput("{file}",output);
  1722.             pr     = nameNPrint;
  1723.             break;
  1724.  
  1725.     default       : internal("Error in graph");
  1726.             break;
  1727.     }
  1728.  
  1729.     if (used<whnfArgs) {        /* Add remaining args to output       */
  1730.     do
  1731.         output = print(pr,FUN_PREC,pushed(used),ap(consSpace,output));
  1732.     while (++used<whnfArgs);
  1733.  
  1734.     if (d>=FUN_PREC) {        /* Determine if parens are needed  */
  1735.         updapRoot(consOpen,revOnto(output,ap(consClose,ss)));
  1736.         return;
  1737.     }
  1738.     }
  1739.  
  1740.     updateRoot(revOnto(output,ss));
  1741. }
  1742.  
  1743. /* --------------------------------------------------------------------------
  1744.  * List printing primitives:
  1745.  * ------------------------------------------------------------------------*/
  1746.  
  1747. static Void local startList(root,ss)    /* start printing evaluated list   */
  1748. StackPtr root;
  1749. Cell     ss; {
  1750.     Cell x    = pushed(0);
  1751.     Cell xs   = pushed(1);
  1752.     Cell temp = evalWithNoError(x);
  1753.     if (nonNull(temp))
  1754.     updapRoot(consOsq,
  1755.            printBadRedex(temp,
  1756.             lprint(nameLPrint,xs,ss)));
  1757.     else if (isChar(whnfHead) && whnfArgs==0)
  1758.     updapRoot(consDQuote,
  1759.            printSChar(charOf(whnfHead),
  1760.             lprint(nameSPrint,xs,ss)));
  1761.     else
  1762.     updapRoot(consOsq,
  1763.            print(namePrint,MIN_PREC,x,
  1764.             lprint(nameLPrint,xs,ss)));
  1765. }
  1766.  
  1767. static Void local startNList(root,ss)    /* start printing unevaluated list */
  1768. StackPtr root;
  1769. Cell     ss; {
  1770.     Cell x    = pushed(0);
  1771.     Cell xs   = pushed(1);
  1772.     unwind(x);
  1773.     if (isChar(whnfHead) && whnfArgs==0)
  1774.     updapRoot(consDQuote,
  1775.            printSChar(charOf(whnfHead),
  1776.             lprint(nameNSPrint,xs,ss)));
  1777.     else
  1778.     updapRoot(consOsq,
  1779.            print(nameNPrint,MIN_PREC,x,
  1780.             lprint(nameNLPrint,xs,ss)));
  1781. }
  1782.  
  1783. primFun(primLPrint) {            /* evaluate and print list       */
  1784.     Cell e    = primArg(2);
  1785.     Cell ss   = primArg(1);
  1786.     Cell temp = evalWithNoError(e);
  1787.  
  1788.     if (nonNull(temp))
  1789.     updateRoot(printString("] ++ ",printBadRedex(temp,ss)));
  1790.     else if (whnfHead==nameCons && whnfArgs==2)
  1791.     updapRoot(consComma,
  1792.            ap(consSpace,
  1793.             print(namePrint,MIN_PREC,pushed(0),
  1794.              lprint(nameLPrint,pushed(1),ss))));
  1795.     else if (whnfHead==nameNil && whnfArgs==0)
  1796.     updapRoot(consCsq,ss);
  1797.     else
  1798.     updateRoot(printString("] ++ ",printBadRedex(e,ss)));
  1799. }
  1800.  
  1801. primFun(primNLPrint) {            /* print list without evaluation   */
  1802.     Cell e  = primArg(2);
  1803.     Cell ss = primArg(1);
  1804.     unwind(e);
  1805.     if (whnfHead==nameCons && whnfArgs==2)
  1806.     updapRoot(consComma,
  1807.            ap(consSpace,
  1808.             print(nameNPrint,MIN_PREC,pushed(0),
  1809.              lprint(nameNLPrint,pushed(1),ss))));
  1810.     else if (whnfHead==nameNil && whnfArgs==0)
  1811.     updapRoot(consCsq,ss);
  1812.     else
  1813.     updateRoot(printString("] ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1814. }
  1815.  
  1816. primFun(primSPrint) {            /* evaluate and print string       */
  1817.     Cell e    = primArg(2);
  1818.     Cell ss   = primArg(1);
  1819.     Cell temp = evalWithNoError(e);
  1820.  
  1821.     if (nonNull(temp))
  1822.     updateRoot(printString("\" ++ ",printBadRedex(temp,ss)));
  1823.     else if (whnfHead==nameCons && whnfArgs==2) {
  1824.     Cell x  = pushed(0);
  1825.     Cell xs = pushed(1);
  1826.     temp    = evalWithNoError(x);
  1827.     if (nonNull(temp))
  1828.         updateRoot(printString("\" ++ [",
  1829.             printBadRedex(temp,
  1830.              lprint(nameLPrint,xs,ss))));
  1831.     else if (isChar(whnfHead) && whnfArgs==0)
  1832.         updateRoot(printSChar(charOf(whnfHead),
  1833.                 lprint(nameSPrint,xs,ss)));
  1834.     else
  1835.         updateRoot(printString("\" ++ [",
  1836.             printBadRedex(x,
  1837.              lprint(nameLPrint,xs,ss))));
  1838.     }
  1839.     else if (whnfHead==nameNil && whnfArgs==0)
  1840.     updapRoot(consDQuote,ss);
  1841.     else
  1842.     updateRoot(printString("\" ++ ",printBadRedex(e,ss)));
  1843. }
  1844.  
  1845. primFun(primNSPrint) {            /* print string without eval       */
  1846.     Cell e  = primArg(2);
  1847.     Cell ss = primArg(1);
  1848.     unwind(e);
  1849.     if (whnfHead==nameCons && whnfArgs==2) {
  1850.     Cell x  = pushed(0);
  1851.     Cell xs = pushed(1);
  1852.     unwind(x);
  1853.     if (isChar(whnfHead) && whnfArgs==0)
  1854.         updateRoot(printSChar(charOf(whnfHead),
  1855.                 lprint(nameNSPrint,xs,ss)));
  1856.     else
  1857.         updateRoot(printString("\" ++ [",
  1858.             print(nameNPrint,MIN_PREC,x,
  1859.              lprint(nameNLPrint,xs,ss))));
  1860.     }
  1861.     else if (whnfHead==nameNil && whnfArgs==0)
  1862.     updapRoot(consDQuote,ss);
  1863.     else
  1864.     updateRoot(printString("\" ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  1865. }
  1866.  
  1867. /* --------------------------------------------------------------------------
  1868.  * Auxiliary functions for printer(s):
  1869.  * ------------------------------------------------------------------------*/
  1870.  
  1871. static Cell local textAsVar(t,ss)    /* reverse t as function symbol       */
  1872. Text t;                    /* onto output ss           */
  1873. Cell ss; {
  1874.     String s = textToStr(t);
  1875.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  1876.     return stringOutput(s,ss);
  1877.     else
  1878.     return ap(consClose,stringOutput(s,ap(consOpen,ss)));
  1879. }
  1880.  
  1881. static Cell local textAsOp(t,ss)    /* reverse t as op. symbol onto ss */
  1882. Text t;
  1883. Cell ss; {
  1884.     String s = textToStr(t);
  1885.     if (isascii(s[0]) && isalpha(s[0]))
  1886.     return ap(consBack,stringOutput(s,ap(consBack,ss)));
  1887.     else
  1888.     return stringOutput(s,ss);
  1889. }
  1890.  
  1891. static Cell local stringOutput(s,ss)    /* reverse string s onto output ss */
  1892. String s;
  1893. Cell   ss; {
  1894.     while (*s)
  1895.     ss = ap(consChar(*s++),ss);
  1896.     return ss;
  1897. }
  1898.  
  1899. static Cell local printBadRedex(rx,rs)    /* Produce expression to print bad */
  1900. Cell rx, rs; {                /* redex and then print rest ...   */
  1901.     return ap(consObrace,
  1902.         print(nameNPrint,MIN_PREC,rx,
  1903.          ap(consCbrace,
  1904.           rs)));
  1905. }
  1906.  
  1907. Void abandon(what,rx)            /* abandon computation           */
  1908. String what;
  1909. Cell   rx; {
  1910.     outputString(errorStream,
  1911.          revOnto(stringOutput("\n",NIL),
  1912.            revOnto(stringOutput(what,NIL),
  1913.           revOnto(stringOutput(" error: ",NIL),
  1914.              printDBadRedex(rx,nameNil)))),TRUE);
  1915.     errAbort();
  1916. }
  1917.  
  1918. /* --------------------------------------------------------------------------
  1919.  * Evaluate name, obtaining a C string from a Gofer string:
  1920.  * ------------------------------------------------------------------------*/
  1921.  
  1922. static String local evalName(es)    /* evaluate es :: [Char] and save  */
  1923. Cell es; {                /* in char array... return ptr to  */
  1924.     static char buffer[FILENAME_MAX+1];    /* string or 0, if error occurs       */
  1925.     Int         pos    = 0;
  1926.     StackPtr    saveSp = sp;
  1927.  
  1928.     while (isNull(evalWithNoError(es)))
  1929.     if (whnfHead==nameCons && whnfArgs==2) {
  1930.         Cell e = pop();        /* avoid leaving anything on stack */
  1931.         es       = pop();
  1932.         if (isNull(evalWithNoError(e))
  1933.             && isChar(whnfHead) && whnfArgs==0
  1934.             && pos<FILENAME_MAX)
  1935.         buffer[pos++] = charOf(whnfHead);
  1936.         else
  1937.         break;
  1938.     }
  1939.     else if (whnfHead==nameNil && whnfArgs==0) {
  1940.         buffer[pos] = '\0';
  1941.         return buffer;
  1942.     }
  1943.     else
  1944.         break;
  1945.  
  1946.     sp = saveSp;            /* stack pointer must be the same  */
  1947.     return 0;                /* as it was on entry           */
  1948. }
  1949.  
  1950. #if MAC
  1951. /* --------------------------------------------------------------------------
  1952.  * Call an OS function from Gofer
  1953.  * ------------------------------------------------------------------------*/
  1954.  
  1955. #if THINKC
  1956. pascal long ToolboxTrap  (unsigned short trap,
  1957.               unsigned short ressize,
  1958.                           unsigned short args,
  1959.                           unsigned short *addr)
  1960. {}
  1961. #else
  1962. extern pascal long ToolboxTrap  (unsigned short trap,unsigned short ressize,unsigned short args,unsigned short *addr);
  1963. #endif
  1964.  
  1965. extern unsigned long trapreg_d0, trapreg_d1, trapreg_a0, trapreg_a1;
  1966.  
  1967. primFun(primTrapReg) {            /* Trap primitive with register settings   */
  1968.     Cell trap    = primArg(6);        /* Result always in D0 */
  1969.     Cell d0      = primArg(5);
  1970.     Cell d1      = primArg(4);
  1971.     Cell a0      = primArg(3);
  1972.     Cell a1      = primArg(2);
  1973.     Cell l       = primArg(1);
  1974.     int i;
  1975.     
  1976.     if(isNull(evalWithNoError(d0)) && isInt(whnfHead) && whnfArgs == 0)
  1977.       {
  1978.         trapreg_d0 = intOf(whnfHead);
  1979.         if(isNull(evalWithNoError(d1)) && isInt(whnfHead) && whnfArgs == 0)
  1980.           {
  1981.              trapreg_d1 = intOf(whnfHead);
  1982.              if(isNull(evalWithNoError(a0)) && isInt(whnfHead) && whnfArgs == 0)
  1983.               {
  1984.                  trapreg_a0 = intOf(whnfHead);
  1985.                  if(isNull(evalWithNoError(a1)) && isInt(whnfHead) && whnfArgs == 0)
  1986.                    {
  1987.                      trapreg_a1 = intOf(whnfHead);
  1988.                      dotrap(root,NIL,trap,l);
  1989.              return;
  1990.            }
  1991.           }
  1992.        }
  1993.       }
  1994.    updapRoot(ap(ap(ap(ap(ap(nameTrapReg,trap),d0),d1),a0),a1),l);
  1995. }
  1996.  
  1997.  
  1998. primFun(primTrap) {            /* Trap primitive           */
  1999.     Cell result  = primArg(3);
  2000.     Cell trap    = primArg(2);
  2001.     Cell l       = primArg(1);
  2002.     dotrap(root,result,trap,l);
  2003. }
  2004.  
  2005.  
  2006. dotrap(root,result,trap,l)
  2007. Cell root,result,trap,l;
  2008. {   
  2009.     unsigned short buffer[128];
  2010.     int cnt    = 0;
  2011.     
  2012.     if(isNull(evalWithNoError(trap)) && isInt(whnfHead) && whnfArgs == 0)
  2013.       {
  2014.         int ttrap = (unsigned short) intOf(whnfHead);
  2015.         if(isNull(result) || (isNull(evalWithNoError(result)) && isInt(whnfHead) && whnfArgs == 0))
  2016.       {
  2017.         int reskind = isNull(result)?0:intOf(whnfHead);
  2018.     
  2019.             while (isNull(evalWithNoError(l)))
  2020.  
  2021.           if (whnfHead==nameCons && whnfArgs==2)
  2022.             {
  2023.               Cell e = pop();        /* avoid leaving anything on stack */
  2024.               l       = pop();
  2025.               if (isNull(evalWithNoError(e))
  2026.               && isInt(whnfHead) && whnfArgs==0
  2027.                   && cnt<127)
  2028.               buffer[cnt++] = (unsigned short) intOf(whnfHead);
  2029.               else
  2030.             break;
  2031.             }
  2032.  
  2033.           else if (whnfHead==nameNil && whnfArgs==0)
  2034.             {
  2035.           unsigned short *bp = buffer;
  2036.               updateRoot(mkInt(ToolboxTrap((unsigned short)ttrap,(unsigned short)reskind,cnt,bp)));
  2037.               return;
  2038.             }
  2039.           else
  2040.             break;
  2041.           }
  2042.       }
  2043.     updapRoot(ap(ap(nameTrap,result),trap),l);
  2044. }
  2045.  
  2046. primFun(primSeq) {            /* Seq primitive           */
  2047.     Cell result  = primArg(1);
  2048.     Cell seq     = primArg(2);
  2049.     if(isNull(evalWithNoError(seq)))
  2050.        updateRoot(result);
  2051.     else
  2052.       updapRoot(ap(nameSeq,seq),result);
  2053. }
  2054.  
  2055.  
  2056. primFun(primTrace) {            /* Trace primitive           */
  2057.     Cell result  = primArg(1);
  2058.     Cell trace   = primArg(2);
  2059.     if(isNull(evalWithNoError(trace)))
  2060.       {
  2061.          fprintf(stderr,"\nTrace: ");
  2062.          printExp(stderr,trace);
  2063.          fputc('\n',stderr);
  2064.          updateRoot(result);
  2065.       }
  2066.     else
  2067.       updapRoot(ap(nameTrace,trace),result);
  2068. }
  2069.  
  2070.  
  2071. /*
  2072.     unitIO x =        IO ( \ t -> x `seq` (x,t))
  2073.  
  2074.     IO u `bindIO` k = IO ( \ t -> let (x,t') =      u t  in
  2075.                                       let eval (IO f) = f t' in
  2076.                                       x `seq` eval (k x))
  2077. */
  2078.  
  2079. primFun(primUnitIO) {
  2080.     Cell action = primArg(1);
  2081.     Cell result = ap(nameIO,ap(nameCUnitIO,action));
  2082.     dotrace("Unitio:   Action =  ",action);
  2083.     updateRoot(result);
  2084. }
  2085.  
  2086. primFun(primCUnitIO) {            /* unitIO primitive -- inner part   */
  2087.     Cell token   = primArg(1);
  2088.     Cell action  = primArg(2);
  2089.     
  2090.     dotrace("CUnitio:  Token =   ",token);
  2091.     dotrace("CUnitio:  Action =  ",action);
  2092.  
  2093.     /* We don't need to evaluate the token: it must be in normal form */
  2094.     if(isNull(evalWithNoError(action)))
  2095.       updateRoot(buildTuple(cons(token,cons(action,NIL))));
  2096.     else
  2097.       updapRoot(nameUnitIO,action);
  2098. }
  2099.  
  2100. /*
  2101. unitIO :: a -> IO a
  2102. unitIO x = IO ( \ t  -> x `seq` (x, t) )
  2103.  
  2104. bindIO :: IO a -> (a -> IO b) -> IO b
  2105. IO u `bindIO` k = IO ( \ t -> let (x,t') =      u t  in
  2106.                               let eval (IO f) = f t' in
  2107.                               x `seq` eval (k x))
  2108. */
  2109.  
  2110.  
  2111. primFun(primBindIO) {
  2112.     Cell cont =   primArg(1);
  2113.     Cell action = primArg(2);
  2114.  
  2115.     dotrace("Bindio:   Action =  ",action);
  2116.     dotrace("Bindio:   Cont =    ",cont);
  2117.  
  2118.     if(isNull(evalWithNoError(action)))
  2119.       {
  2120.         action = pop();
  2121.     cont = ap(nameIO,ap(ap(nameCBindIO,action),cont));
  2122.     
  2123.         dotrace("Bindio:   Action2 = ",action);
  2124.         dotrace("Bindio:   Cont2 =   ",cont);
  2125.  
  2126.     /* Eval will force this without growing the C stack */    
  2127.     updateRoot(cont);
  2128.       }
  2129.     else
  2130.       updapRoot(ap(nameBindIO,action),cont);
  2131. }
  2132.  
  2133.  
  2134. primFun(primCBindIO) {            /* bindIO primitive -- inner part   */
  2135.     Cell token   = primArg(1);
  2136.     Cell cont    = primArg(2);
  2137.     Cell action  = primArg(3);
  2138.     Cell action2 = ap(action,token);
  2139.     
  2140.     dotrace("CBindio:  Token =   ",token);
  2141.     dotrace("CBindio:  Cont =    ",cont);
  2142.     dotrace("CBindio:  Action =  ",action);
  2143.  
  2144.     /* Stub out for GC */    
  2145.     action = NIL;
  2146.     
  2147.     if(isNull(evalWithNoError(action2)))
  2148.       {
  2149.      action2 = pop();
  2150.      token =  pop();
  2151.  
  2152.          dotrace("CBindio:  Token2 =  ",token);
  2153.          dotrace("CBindio:  Action2 = ",action2);
  2154.  
  2155.      if(isNull(evalWithNoError(action2)))
  2156.        {
  2157.              dotrace("CBindio:  Action3 = ",action2);
  2158.          updapRoot(ap(nameCCBindIO,ap(cont,action2)),token);
  2159.          return;
  2160.        }
  2161.       }
  2162.  
  2163.     updapRoot(ap(nameBindIO,action),cont);
  2164. }
  2165.  
  2166.  
  2167. primFun(primCCBindIO) {
  2168.     Cell token = primArg(1);
  2169.     Cell action = primArg(2);
  2170.  
  2171.     dotrace("CCBindio: Action =  ",action);
  2172.     dotrace("CCBindio: Token =   ",token);
  2173.     
  2174.     if(isNull(evalWithNoError(action)))
  2175.      {
  2176.     action = pop();
  2177.  
  2178.         dotrace("CCBindio: Action2 = ",action);
  2179.     
  2180.     updapRoot(action,token);
  2181.       }
  2182.     else
  2183.       updapRoot(nameBindIO,action);
  2184. }   
  2185.  
  2186.  
  2187. primFun(primAssign) {            /* Assign primitive           */
  2188.     Cell value  = primArg(1);
  2189.     Cell ptr    = primArg(2);
  2190.     if(isNull(evalWithNoError(ptr))     && 
  2191.        isInt(whnfHead) && whnfArgs == 0)
  2192.          {
  2193.            Cell eptr = whnfHead;
  2194.            if(isNull(evalWithNoError(value))   &&
  2195.               isInt(whnfHead) && whnfArgs == 0 )
  2196.            {
  2197.              (*(int *)intOf(eptr)) = intOf(whnfHead);
  2198.              updateRoot(mkInt(0));
  2199.            }
  2200.      }
  2201.     else
  2202.       updapRoot(ap(nameAssign,ptr),value);
  2203. }
  2204.  
  2205.  
  2206. primFun(primAssignS) {            /* Short Assign primitive       */
  2207.     Cell value  = primArg(1);
  2208.     Cell ptr    = primArg(2);
  2209.     Cell eptr   = evalWithNoError(ptr);
  2210.     Cell evalue; 
  2211.  
  2212.     if(isNull(eptr) && isInt(whnfHead) && whnfArgs == 0)
  2213.        if(isNull(evalue=evalWithNoError(value))   &&
  2214.             isInt(whnfHead) && whnfArgs == 0 )
  2215.          {
  2216.            (*(short *)intOf(eptr)) = (short) intOf(evalue);
  2217.            updateRoot(mkInt(0));
  2218.          }
  2219.     else
  2220.       updapRoot(ap(nameAssignS,ptr),value);
  2221. }
  2222.  
  2223.  
  2224. primFun(primAssignC) {            /* Char Assign primitive       */
  2225.     Cell value  = primArg(1);
  2226.     Cell ptr     = primArg(2);
  2227.     if(isNull(evalWithNoError(ptr))     && 
  2228.        isInt(whnfHead) && whnfArgs == 0)
  2229.          {
  2230.            Cell eptr = whnfHead;
  2231.            if(isNull(evalWithNoError(value))   &&
  2232.               isInt(whnfHead) && whnfArgs == 0 )
  2233.            {
  2234.              (*(char *)intOf(eptr)) = (char) intOf(whnfHead);
  2235.              updateRoot(mkInt(0));
  2236.            }
  2237.      }
  2238.     else
  2239.       updapRoot(ap(nameAssignC,ptr),value);
  2240. }
  2241.  
  2242.  
  2243. primFun(primAssignBlock) {            /* Short Assign primitive       */
  2244.     Cell values  = primArg(1);
  2245.     Cell ptr     = primArg(2);
  2246.     
  2247.     if(isNull(evalWithNoError(ptr)) && isInt(whnfHead) && whnfArgs == 0)
  2248.       {
  2249.          short *sptr = (short *) intOf(whnfHead);
  2250.     
  2251.          while (isNull(evalWithNoError(values)))
  2252.  
  2253.        if (whnfHead==nameCons && whnfArgs==2)
  2254.          {
  2255.            Cell e = pop();        /* avoid leaving anything on stack */
  2256.            values = pop();
  2257.            if (isNull(evalWithNoError(e)) && isInt(whnfHead) && whnfArgs==0)
  2258.          (*sptr++) = (short) intOf(whnfHead);
  2259.            else
  2260.          break;
  2261.          }
  2262.  
  2263.        else if (whnfHead==nameNil && whnfArgs==0)
  2264.          {
  2265.            updateRoot(mkInt(0));
  2266.            return;
  2267.          }
  2268.        else
  2269.          break;
  2270.       }
  2271.     updapRoot(ap(nameAssignBlock,ptr),values);
  2272. }
  2273.  
  2274.  
  2275. primFun(primDeref) {            /* Deref primitive           */
  2276.     Cell ptr  = primArg(1);
  2277.     Cell val  = 0;
  2278.     if(isNull(evalWithNoError(ptr))  &&
  2279.        isInt(whnfHead) && whnfArgs == 0 )
  2280.     {
  2281.           val = *(int *)(intOf(whnfHead));
  2282.           updateRoot(mkInt(val));
  2283.     }
  2284.     else
  2285.       updapRoot(nameDeref,ptr);
  2286. }
  2287.    
  2288.  
  2289. primFun(primMalloc) {            /* Malloc primitive           */
  2290.     Cell size  = primArg(1);
  2291.     if(isNull(evalWithNoError(size)) &&
  2292.        isInt(whnfHead) && whnfArgs == 0 )
  2293.       {
  2294.         extern char *malloc();
  2295.         int thesize = intOf(whnfHead);
  2296.     char *ptr = malloc(thesize);
  2297.         updateRoot(mkInt((int)ptr));
  2298.       }
  2299.     else
  2300.       updapRoot(nameMalloc,size);
  2301. }
  2302.  
  2303. primFun(primFree) {            /* Free primitive           */
  2304.     Cell ptr  = primArg(1);
  2305.     if(isNull(evalWithNoError(ptr))  &&
  2306.        isInt(whnfHead) && whnfArgs == 0 )
  2307.          {
  2308.        free((void *)intOf(whnfHead));
  2309.            updateRoot(mkInt(0));
  2310.      }
  2311.     else
  2312.       updapRoot(nameFree,ptr);
  2313. }
  2314.  
  2315.  
  2316. /* Now some "essential" ToolBox routines */
  2317. primFun(primButton) {            /* Button primitive           */
  2318.     Cell arg  = primArg(1);
  2319.     if(isNull(evalWithNoError(arg))  && whnfArgs == 0 )
  2320.        updateRoot(mkInt((int)Button()));
  2321.     else
  2322.       updapRoot(nameButton,arg);
  2323. }
  2324.  
  2325.  
  2326. primFun(primGetMouse) {            /* GetMouse primitive           */
  2327. #if !THINKC
  2328.     Cell arg  = primArg(1);
  2329.     if(isNull(evalWithNoError(arg))  && whnfArgs == 0 )
  2330.        updateRoot(mkInt((int)GetMouse((Point *)intOf(arg))));
  2331.     else
  2332.       updapRoot(nameGetMouse,arg);
  2333. #endif
  2334. }
  2335.  
  2336. #if MPW
  2337. #pragma segment Builtin3
  2338. #endif
  2339.  
  2340. primFun(primLineTo) {            /* LineTo primitive       */
  2341.     Cell y  = primArg(1);
  2342.     Cell x  = primArg(2);
  2343.     
  2344.     if(isNull(evalWithNoError(x)) && isInt(whnfHead) && whnfArgs == 0)
  2345.       {
  2346.          int xvalue = intOf(whnfHead);
  2347.          if(isNull(evalWithNoError(y)) && isInt(whnfHead) && whnfArgs == 0)
  2348.        {
  2349.           LineTo(xvalue,intOf(whnfHead));
  2350.               updateRoot(UNIT);
  2351.           return;
  2352.        }
  2353.       }
  2354.     updapRoot(ap(nameLineTo,x),y);
  2355. }
  2356.  
  2357. primFun(primMoveTo) {            /* MoveTo primitive       */
  2358.     Cell y  = primArg(1);
  2359.     Cell x  = primArg(2);
  2360.     
  2361.     if(isNull(evalWithNoError(x)) && isInt(whnfHead) && whnfArgs == 0)
  2362.       {
  2363.          int xvalue = intOf(whnfHead);
  2364.          if(isNull(evalWithNoError(y)) && isInt(whnfHead) && whnfArgs == 0)
  2365.        {
  2366.           MoveTo(xvalue,intOf(whnfHead));
  2367.               updateRoot(UNIT);
  2368.           return;
  2369.        }
  2370.       }
  2371.     updapRoot(ap(nameMoveTo,x),y);
  2372. }
  2373.  
  2374.  
  2375. primFun(primGetNextEvt) {            /* Event primitive           */
  2376.     Cell mask  = primArg(1);
  2377.     if(isNull(evalWithNoError(mask))  && whnfArgs == 0 )
  2378.       primgetnextevent(root,whnfHead,FALSE);
  2379.     else
  2380.       updapRoot(nameGetNextEvt,mask);
  2381. }
  2382.  
  2383.  
  2384. primFun(primEvtAvail) {            /* Event available primitive           */
  2385.     Cell mask  = primArg(1);
  2386.     if(isNull(evalWithNoError(mask))  && whnfArgs == 0 )
  2387.       primgetnextevent(root,whnfHead,TRUE);
  2388.     else
  2389.       updapRoot(nameEvtAvail,mask);
  2390. }
  2391.  
  2392. /* Get next event primitive separated because of stack problems */
  2393. primgetnextevent(root,evtmask,checkonly)
  2394. Cell root, evtmask;
  2395. Bool checkonly;
  2396. {
  2397.    extern EventRecord myEvent;
  2398.    List result; 
  2399.  
  2400.    /* Get next event into myEvent */
  2401.    GetNextKbdEvent(intOf(evtmask),checkonly);
  2402.    
  2403.    /* buildTuple builds in reverse order! */
  2404.    result = cons(mkInt((int)(myEvent.modifiers)),
  2405.              cons(mkInt(myEvent.where),
  2406.                cons(mkInt(myEvent.when),
  2407.                 cons(mkInt(myEvent.message),
  2408.              cons(mkInt((int)(myEvent.what)),NIL)))));
  2409.  
  2410.    updateRoot(buildTuple(result));
  2411. }
  2412.  
  2413.  
  2414. /* --------------------------------------------------------------------------
  2415.  * Callbacks:
  2416.  *
  2417.  * A fixed buffer of callback functions is maintained.
  2418.  *
  2419.  * ------------------------------------------------------------------------*/
  2420.  
  2421.  #if 1
  2422.  #define MAX_CALLBACKS 5
  2423.  
  2424.  struct Callbacks
  2425.    {
  2426.      Cell callback;
  2427.      int (*cfun)();
  2428.    } Callbacks[MAX_CALLBACKS];
  2429.  
  2430. pascal int callback_0_0()
  2431. {
  2432.   return(callback_n(0,0,0));
  2433. }
  2434.  
  2435. pascal int callback_1_0(arg0)
  2436. short arg0;
  2437. {
  2438.   return(callback_n(0,1,(int)arg0));
  2439. }
  2440.  
  2441. pascal int callback_2_0(arg0)
  2442. int arg0;
  2443. {
  2444.   return(callback_n(0,2,arg0));
  2445. }
  2446.  
  2447. pascal int callback_0_1()
  2448. {
  2449.   return(callback_n(1,0,0));
  2450. }
  2451.  
  2452. pascal int callback_1_1(arg0)
  2453. short arg0;
  2454. {
  2455.   return(callback_n(1,1,(int)arg0));
  2456. }
  2457.  
  2458. pascal int callback_2_1(arg0)
  2459. int arg0;
  2460. {
  2461.   return(callback_n(1,2,arg0));
  2462. }
  2463.  
  2464. pascal int callback_0_2()
  2465. {
  2466.   return(callback_n(2,0,0));
  2467. }
  2468.  
  2469. pascal int callback_1_2(arg0)
  2470. short arg0;
  2471. {
  2472.   return(callback_n(2,1,(int)arg0));
  2473. }
  2474.  
  2475. pascal int callback_2_2(arg0)
  2476. int arg0;
  2477. {
  2478.   return(callback_n(2,2,arg0));
  2479. }
  2480.  
  2481. pascal int callback_0_3()
  2482. {
  2483.   return(callback_n(3,0,0));
  2484. }
  2485.  
  2486. pascal int callback_1_3(arg0)
  2487. short arg0;
  2488. {
  2489.   return(callback_n(3,1,(int)arg0));
  2490. }
  2491.  
  2492. pascal int callback_2_3(arg0)
  2493. int arg0;
  2494. {
  2495.   return(callback_n(3,2,arg0));
  2496. }
  2497.  
  2498. pascal int callback_0_4()
  2499. {
  2500.   return(callback_n(4,0,0));
  2501. }
  2502.  
  2503. pascal int callback_1_4(arg0)
  2504. short arg0;
  2505. {
  2506.   return(callback_n(4,1,(int)arg0));
  2507. }
  2508.  
  2509. pascal int callback_2_4(arg0)
  2510. int arg0;
  2511. {
  2512.   return(callback_n(4,2,arg0));
  2513. }
  2514.  
  2515. int callback_n(n,argc,arg)
  2516. int n, argc, arg;
  2517. {
  2518.   Int i;
  2519.   Cell callback = Callbacks[n].callback;
  2520.  
  2521.   if(argc == 0)
  2522.     callback = ap(callback,UNIT);
  2523.   else
  2524.     callback = ap(ap(callback,mkInt(arg)),UNIT);
  2525.  
  2526.   callback = evalWithNoError(callback);
  2527.  
  2528.   if(isNull(callback))
  2529.     return(intOf(whnfHead));
  2530.   else
  2531.     return(0);
  2532. }
  2533.  
  2534. #if 0
  2535. int CallbackFns[2][] =
  2536. {
  2537.   (int) callback_0_0, (int) callback_1_0, (int) callback_2_0,
  2538.   (int) callback_0_1, (int) callback_1_1, (int) callback_2_1,
  2539.   (int) callback_0_2, (int) callback_1_2, (int) callback_2_2,
  2540.   (int) callback_0_3, (int) callback_1_3, (int) callback_2_3,
  2541.   (int) callback_0_4, (int) callback_1_4, (int) callback_2_4
  2542. };
  2543. #else
  2544. int CallbackFns[2][];
  2545. #endif
  2546.  
  2547. pascal int DummyCallBack()
  2548. {
  2549.   printf("Too many callbacks used\n");
  2550.   return(0);
  2551. }
  2552.    
  2553. primFun(primCreateCallback) {            /* Create Callback primitive           */
  2554.   Cell argsize =  primArg(2);
  2555.   Cell callback = primArg(1);
  2556.  
  2557.   if(isNull(evalWithNoError(argsize)) && whnfArgs == 0)
  2558.     {
  2559.       Int i;
  2560.       Int args = intOf(whnfHead);
  2561.  
  2562.       if(args > 2 || args < 0)
  2563.         abandon("Callback",ap(ap(nameCreateCallback,argsize),callback));
  2564.       else
  2565.         {
  2566.           for ( i =0; i < MAX_CALLBACKS; ++i)
  2567.             if(Callbacks[i].callback == NULL)
  2568.               {
  2569.         Callbacks[i].callback = callback;
  2570. #if 0
  2571.         Callbacks[i].cfun = (int (*)())CallbackFns[args][i];
  2572.         updateRoot(mkInt((Int)Callbacks[i].cfun));
  2573. #endif
  2574.         return;
  2575.               }
  2576.  
  2577. #if 0
  2578.       updateRoot(mkInt((Int)DummyCallback));
  2579. #endif
  2580.     }
  2581.     }
  2582.   else
  2583.     updapRoot(ap(nameCreateCallback,argsize),callback);
  2584. }
  2585.  
  2586. primFun(primDisposeCallback)
  2587. {
  2588.   Cell callback = primArg(1);
  2589.   Int i;
  2590.   if(isNull(evalWithNoError(callback))  && whnfArgs == 0 )
  2591.     for ( i =0; i < MAX_CALLBACKS; ++i)
  2592.       if((int) Callbacks[i].cfun == intOf(whnfHead))
  2593.         {
  2594.           Callbacks[i].callback = NULL;
  2595.       break;
  2596.         }
  2597.   else
  2598.     updapRoot(nameDisposeCallback,callback);
  2599. }
  2600. #endif
  2601. #endif
  2602.  
  2603.  
  2604. /* --------------------------------------------------------------------------
  2605.  * Dialogue based input/output:
  2606.  *
  2607.  * N.B. take care when modifying this code - it is rather delicate and even
  2608.  * the simplest of changes might create a nasty space leak... you have been
  2609.  * warned (please let me know if you think there already is a space leak!).
  2610.  * ------------------------------------------------------------------------*/
  2611.  
  2612. static Name nameInput;            /* For reading from stdin       */
  2613.  
  2614. static Bool echoChanged;        /* TRUE => echo changed in dialogue*/
  2615. static Bool stdinUsed;            /* TRUE => ReadChan stdin has been */
  2616.                     /*       seen in dialogue       */
  2617. static FILE *writingFile = 0;        /* points to file open for writing */
  2618.  
  2619.  
  2620. Void dialogue(prog)            /* carry out dialogue ...       */
  2621. Cell prog; {                /* :: Dialog=[Response]->[Request] */
  2622.     static String ioerr = "Attempt to read response before request complete";
  2623.     Cell tooStrict      = mkStr(findText(ioerr));
  2624.     Cell resps        = prog = ap(prog,NIL);
  2625.     Cell temp;
  2626.  
  2627.     echoChanged = FALSE;
  2628.     stdinUsed   = FALSE;
  2629.     for (;;) {                /* Keep Responding to Requests       */
  2630.     resps = snd(resps) = ap(nameError,tooStrict);
  2631.         clearStack();
  2632.     if (nonNull(temp=evalWithNoError(prog)))
  2633.         abandonDialogue(temp);
  2634.     else if (whnfHead==nameCons && whnfArgs==2) {
  2635.         if (nonNull(temp=evalWithNoError(pushed(0))))
  2636.         abandonDialogue(temp);
  2637.  
  2638.         prog = pushed(1+whnfArgs);
  2639.  
  2640.         if (whnfHead==nameReadFile && whnfArgs==1)
  2641.         fst(resps) = ap(nameCons,readFile());
  2642.         else if (whnfHead==nameWriteFile && whnfArgs==2)
  2643.         fst(resps) = ap(nameCons,writeFile());
  2644.         else if (whnfHead==nameAppendFile && whnfArgs==2)
  2645.         fst(resps) = ap(nameCons,appendFile());
  2646.         else if (whnfHead==nameReadChan && whnfArgs==1)
  2647.         fst(resps) = ap(nameCons,readChan());
  2648.         else if (whnfHead==nameAppendChan && whnfArgs==2)
  2649.         fst(resps) = ap(nameCons,appendChan());
  2650.         else if (whnfHead==nameEcho && whnfArgs==1)
  2651.         fst(resps) = ap(nameCons,echo());
  2652.         else if (whnfHead==nameGetArgs && whnfArgs==0)
  2653.         fst(resps) = ap(nameCons,getCLArgs());
  2654.         else if (whnfHead==nameGetProgName && whnfArgs==0)
  2655.         fst(resps) = ap(nameCons,getProgName());
  2656.         else if (whnfHead==nameGetEnv && whnfArgs==1)
  2657.         fst(resps) = ap(nameCons,getEnv());
  2658. #if MAC
  2659.             else if (whnfHead==nameImperate && whnfArgs==1)
  2660.         fst(resps) = ap(nameCons,imperate());
  2661. #endif
  2662.         else
  2663.         abandonDialogue(pushed(whnfArgs));
  2664.     }
  2665.     else if (whnfHead==nameNil && whnfArgs==0) {
  2666.         normalTerminal();
  2667.         return;
  2668.     }
  2669.     else
  2670.         internal("Type error during Dialogue");
  2671.     }
  2672. }
  2673.  
  2674. static Void local abandonDialogue(rx)    /* abandon dialogue after failure  */
  2675. Cell rx; {                /* to reduce redex rx           */
  2676.     abandon("Dialogue",rx);
  2677. }
  2678.  
  2679. static Cell local printDBadRedex(rx,rs) /* Produce expression for bad redex*/
  2680. Cell rx, rs; {                /* within a Dialogue, with special */
  2681.     if (isAp(rx) && fun(rx)==nameError) /* handling of {error str} redexes */
  2682.     return arg(rx);
  2683.     else
  2684.     return printBadRedex(rx,rs);
  2685. }
  2686.  
  2687. static Cell local readFile() {        /* repond to ReadFile request       */
  2688.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  2689.     Cell   temp = NIL;            /* pushed(1) = ReadFile request       */
  2690.                     /* pushed(2) = rest of program       */
  2691.  
  2692.     if (!s)                /* problem with filename?       */
  2693.     abandonDialogue(pushed(1));
  2694.     if (access(s,0)!=0)            /* can't find file           */ 
  2695.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2696.     if (isNull(temp = openFile(s)))    /* can't open file           */
  2697.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  2698.     return ap(nameStr,temp);        /* otherwise we got a file!       */
  2699. }
  2700.  
  2701. static Cell local writeFile() {        /* respond to WriteFile req.       */
  2702.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  2703.     FILE   *fp;                /* pushed(1) = output string       */
  2704.     Cell   temp;            /* pushed(2) = output request       */
  2705.                     /* pushed(3) = rest of program       */
  2706.  
  2707.     if (!s)                /* problem with filename?          */
  2708.         abandonDialogue(pushed(2));
  2709. #if MAC
  2710.     createTextFile(s);            /* Not automatically created on write */
  2711. #endif
  2712.     if ((fp=fopen(s,FOPEN_WRITE))==0)    /* problem with output file?       */
  2713.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  2714.     writingFile = fp;
  2715.     temp        = outputString(fp,pushed(1),FALSE);
  2716.     fclose(fp);
  2717.     writingFile = 0;
  2718.     if (nonNull(temp))
  2719.     return ap(nameFailure,ap(nameWriteError,temp));
  2720.     else
  2721.     return nameSuccess;
  2722. }
  2723.  
  2724. static Cell local appendFile() {    /* respond to AppendFile req.       */
  2725.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  2726.     FILE   *fp;                /* pushed(1) = output string       */
  2727.     Cell   temp;            /* pushed(2) = output request       */
  2728.                     /* pushed(3) = rest of program       */
  2729.  
  2730.     if (!s)                /* problem with filename?          */
  2731.         abandonDialogue(pushed(2));
  2732.     if (access(s,0)!=0)            /* can't find file?           */
  2733.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2734.     if ((fp=fopen(s,FOPEN_APPEND))==0)    /* problem with output file?       */
  2735.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  2736.     writingFile = fp;
  2737.     temp        = outputString(fp,pushed(1),FALSE);
  2738.     fclose(fp);
  2739.     writingFile = 0;
  2740.     if (nonNull(temp))
  2741.     return ap(nameFailure,ap(nameWriteError,temp));
  2742.     else
  2743.     return nameSuccess;
  2744. }
  2745.  
  2746. static Cell local readChan() {        /* respond to readChan req.       */
  2747.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  2748.                     /* pushed(1) = output request       */
  2749.                     /* pushed(2) = rest of program       */
  2750.  
  2751.     if (!s)                /* problem with filename?       */
  2752.     abandonDialogue(pushed(1));
  2753.     if (strcmp(s,"stdin")!=0)        /* only valid channel == stdin       */
  2754.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2755.     if (stdinUsed)            /* can't reuse stdin channel!      */
  2756.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  2757.     stdinUsed = TRUE;
  2758.     return ap(nameStr,ap(nameInput,UNIT));
  2759. }
  2760.  
  2761. static Cell local appendChan() {    /* respond to AppendChannel req.   */
  2762.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  2763.     FILE   *fp;                /* pushed(1) = output string       */
  2764.     Cell   temp;            /* pushed(2) = output request       */
  2765.                     /* pushed(3) = rest of program       */
  2766.  
  2767.     if (!s)                /* problem with filename?          */
  2768.         abandonDialogue(pushed(2));
  2769.     if ((fp = validOutChannel(s))==0)    /* problem with output channel?       */
  2770.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2771.     if (nonNull(temp=outputString(fp,pushed(1),FALSE)))
  2772.     return ap(nameFailure,ap(nameWriteError,temp));
  2773.     else
  2774.     return nameSuccess;
  2775. }
  2776.  
  2777. static FILE *local validOutChannel(s)    /* return FILE * for valid output  */
  2778. String s; {                /* channel name or 0 otherwise...  */
  2779.     if (strcmp(s,"stdout")==0)
  2780.     return stdout;
  2781.     if (strcmp(s,"stderr")==0)
  2782.     return stderr;
  2783.     if (strcmp(s,"stdecho")==0)        /* in Gofer, stdecho==stdout       */
  2784.     return stdout;
  2785.     return 0;
  2786. }
  2787.  
  2788. #if MAC
  2789. extern Bool HandlingEvents;        /* TRUE => Mac I/O taking place       */
  2790.  
  2791. static Cell local imperate() {        /* respond to Imperate request       */
  2792.                         /* pushed(0) = imperative action */
  2793.                     /* pushed(1) = imperate request       */
  2794.                     /* pushed(2) = rest of program       */
  2795.     Cell expr, action = pushed(0);
  2796.  
  2797.     /* Set the context for a MacGofer "application" */    
  2798.     useprojectresfile(TRUE,FALSE);            /* Use the resources from the Project */
  2799.     HandlingEvents = TRUE;
  2800.     HideMenus(TRUE);                    /* Hide the MacGofer menus    */
  2801.     HideAllWindows(TRUE);                /* And all the windows        */
  2802.     InitCursor();                    /* Reset the cursor to an arrow    */
  2803.  
  2804.  
  2805.     /* Evaluate expr in the context of an event-handling program */
  2806.     /*  The token version uses UNIT to represent the hidden system state.  */
  2807.  
  2808.     expr = evalWithNoError(action);            /* First evaluate the constructor */ 
  2809.     /*
  2810.        Now do case analysis on the constructor 
  2811.        and apply the encapsulated function to the State
  2812.     */
  2813.  
  2814.      if(isName(whnfHead) && name(whnfHead).defn == CFUN)
  2815.       {
  2816.         Cell action = pop();                /* Get the action argument from the stack */
  2817.         Cell appliedAction = ap(action,UNIT);
  2818.         expr = evalWithNoError(appliedAction);
  2819.         if(isNull(expr))
  2820.       {
  2821.          Cell state = pop();
  2822.          Cell result = pop();
  2823.          if(isNull(expr=evalWithNoError(state)))
  2824.            expr = evalWithNoError(result);
  2825.       }
  2826.       }
  2827.  
  2828.  
  2829.     /* Reset the context for a normal Gofer program */
  2830.     FlushEvents (everyEvent,0 );                /* Clear all outstanding events          */
  2831.     HideMenus(FALSE);                /* Restore the menus              */
  2832.     HideAllWindows(FALSE);            /* Show all the MacGofer windows      */
  2833.     updatewindows();                /* And redraw them              */        
  2834.     useprojectresfile(FALSE,FALSE);        /* Restore Resources from the application */
  2835.     HandlingEvents = FALSE;
  2836.     FlushEvents (mDownMask|mUpMask,0 );         /* Clear any mouse events events      */
  2837.  
  2838.     if (isNull(expr))
  2839.       return(nameSuccess);
  2840.     else
  2841.       abandonDialogue(pushed(1));
  2842.     return NIL;/*NOTREACHED*/
  2843. }
  2844.  
  2845. #endif
  2846.  
  2847.  
  2848. static Cell local echo() {        /* respond to Echo request       */
  2849.                         /* pushed(0) = boolean echo status */
  2850.                     /* pushed(1) = echo request       */
  2851.                     /* pushed(2) = rest of program       */
  2852.     static String inUse  = "stdin already in use";
  2853.     static String repeat = "repeated Echo request";
  2854.  
  2855.     if (isNull(evalWithNoError(pushed(0)))) {
  2856.     if (stdinUsed)
  2857.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(inUse))));
  2858.     if (echoChanged)
  2859.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(repeat))));
  2860.     if (whnfHead==nameFalse && whnfArgs==0) {
  2861.         echoChanged = TRUE;
  2862.         noechoTerminal();
  2863.         return nameSuccess;
  2864.     }
  2865.     if (whnfHead==nameTrue && whnfArgs==0) {
  2866.         echoChanged = TRUE;
  2867.         return nameSuccess;
  2868.     }
  2869.     }
  2870.     abandonDialogue(pushed(1));
  2871.     return NIL;/*NOTREACHED*/
  2872. }
  2873.  
  2874. static Cell local getCLArgs() {        /* get command args -- always []   */
  2875.     return ap(nameStrList,nameNil);
  2876. }
  2877.  
  2878. static Cell local getProgName() {    /* get program name -- an error!   */
  2879.     return ap(nameFailure,ap(nameOtherError,nameNil));
  2880. }
  2881.  
  2882. static Cell local getEnv() {        /* get environment variable       */
  2883.     String s = evalName(pushed(0));    /* pushed(0) = variable name string*/
  2884.     String r = 0;            /* pushed(1) = output request       */
  2885.                     /* pushed(2) = rest of program       */
  2886.     if (!s)
  2887.         abandonDialogue(pushed(1));
  2888.     if (r=getenv(s))
  2889.     return ap(nameStr,revOnto(stringOutput(r,NIL),nameNil));
  2890.     else
  2891.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  2892. }
  2893.  
  2894. primFun(primInput) {            /* read single character from stdin*/
  2895.     Int c = readTerminalChar();
  2896.  
  2897.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  2898.     clearerr(stdin);
  2899.     updateRoot(nameNil);
  2900.     }
  2901.     else
  2902.     updapRoot(consChar(c),ap(nameInput,UNIT));
  2903. }
  2904.  
  2905. primFun(primFopen) {            /* open file for reading as str       */
  2906.     Cell   succ = primArg(1);        /*  :: String->a->(String->a)->a   */
  2907.     Cell   fail = primArg(2);
  2908.     String s    = evalName(primArg(3));
  2909.  
  2910.     if (s){
  2911.     Cell file = openFile(s);
  2912.     if (nonNull(file)) {
  2913.         updapRoot(succ,file);
  2914.         return;
  2915.     }
  2916.     }
  2917.     updateRoot(fail);
  2918. }
  2919.  
  2920. /* --------------------------------------------------------------------------
  2921.  * Top-level printing mechanism:
  2922.  * ------------------------------------------------------------------------*/
  2923.  
  2924. Cell outputString(fp,cs,noDialogue)    /* Evaluate string cs and print       */
  2925. FILE *fp;                /* on specified output stream fp   */
  2926. Cell cs;
  2927. Bool noDialogue; {            /* TRUE => not runnning Dialogue   */
  2928.     Cell temp;
  2929.  
  2930.     for (;;) {                /* keep reducing and printing head */
  2931.     clearStack();            /* character               */
  2932.     temp = evalWithNoError(cs);
  2933.     if (nonNull(temp))
  2934.         if (noDialogue)
  2935.         cs = printBadRedex(temp,nameNil);
  2936.         else
  2937.         return printDBadRedex(temp,nameNil);
  2938.     else if (whnfHead==nameCons && whnfArgs==2) {
  2939.         Cell c = pushed(0);
  2940.         cs     = pushed(1);
  2941.  
  2942.         if (nonNull(temp=evalWithNoError(c)))
  2943.         if (noDialogue)
  2944.             cs = printBadRedex(temp,cs);
  2945.         else
  2946.             return printDBadRedex(temp,cs);
  2947.         else if (isChar(whnfHead) && whnfArgs==0) {
  2948.             if(!traceEval || !noDialogue) {
  2949.             fputc(charOf(whnfHead),fp);
  2950.             if(!writingFile)
  2951.                 fflush(fp);
  2952.         }
  2953.         }
  2954.         else
  2955.         break;
  2956.     }
  2957.     else if (whnfHead==nameNil && whnfArgs==0) {
  2958.         if(writingFile)
  2959.            fflush(fp);
  2960.         return NIL;
  2961.     }
  2962.     else
  2963.         break;
  2964.     }
  2965.     internal("runtime type error");
  2966.     return nameNil;/*NOTREACHED*/
  2967. }
  2968.  
  2969. /* --------------------------------------------------------------------------
  2970.  * Lambda-var prototype implementation:
  2971.  * ------------------------------------------------------------------------*/
  2972.  
  2973. #ifdef LAMBDAVAR
  2974. Void lvExecute(prog)            /* execute lambda var prog of type */
  2975. Cell prog; {                /* Proc ()               */
  2976.     Cell temp;
  2977.     noechoTerminal();
  2978.     temp = evalWithNoError(ap(prog,UNIT));
  2979.     if (nonNull(temp))
  2980.     abandon("Program execution",temp);
  2981. }
  2982.  
  2983. primFun(primLvReturn) {            /* lambda var return           */
  2984.     updateRoot(primArg(2));        /* return    :: a -> Proc a       */
  2985.                     /* return e _ = e           */
  2986. }
  2987.  
  2988. primFun(primLvPure) {            /* lambda var pure           */
  2989.     updapRoot(primArg(1),UNIT);        /* pure  :: Proc a -> a           */
  2990.                     /* pure e = e ()           */
  2991. }
  2992.  
  2993. primFun(primLvRead) {            /* lambda var reader           */
  2994.     Cell v = primArg(3);        /* (?)::Var a->(a->Proc b)->Proc b */
  2995.     Cell f = primArg(2);        /* (Var v ? f) () ===> f v ()       */
  2996.     eval(v);
  2997.     if (whnfHead!=nameVar || whnfArgs!=1)
  2998.     internal("type error in reader");
  2999.     updapRoot(ap(f,pushed(0)),UNIT);
  3000. }
  3001.  
  3002. primFun(primLvBind) {            /* lambda var bind           */
  3003.     Cell m = primArg(3);        /*($=)::Proc a->(a->Proc b)->Proc b*/
  3004.     Cell f = primArg(2);        /* (m $= f) () ===> f (m ()) ()       */
  3005.     Cell a = ap(m,UNIT);        /* strict in first argument       */
  3006.     eval(a);
  3007.     updapRoot(ap(f,a),UNIT);
  3008. }
  3009.  
  3010. primFun(primLvVar) {            /* lambda var, new variable       */
  3011.     updapRoot(ap(primArg(2),        /* var :: (Var a -> Proc b)->Proc b*/
  3012.          ap(nameVar,        /* var f () = f {newvar} ()       */
  3013.             nameLvUnbound)),
  3014.           UNIT);
  3015. }
  3016.  
  3017. primFun(primLvNewvar) {            /* lambda var, improved new var       */
  3018.     updapRoot(nameVar,nameLvUnbound);    /* newvar   :: Proc (Var a)       */
  3019.                     /* newvar () = {newVar}           */
  3020. }
  3021.  
  3022. primFun(primLvAssign) {            /* lambda var assign           */
  3023.     Cell e = primArg(3);        /* assign :: a -> Var a -> Proc () */
  3024.     Cell v = primArg(2);            /* assign e (Var v) () = ()       */
  3025.     eval(v);
  3026.     if (whnfHead!=nameVar || whnfArgs!=1)
  3027.     internal("type error in assign");
  3028.     snd(v) = e;                /* Arrgh! impurity!           */
  3029.     updateRoot(UNIT);
  3030. }
  3031.  
  3032. primFun(primLvVarEq) {            /* lambda var equality for Vars       */
  3033.     Cell x = primArg(2);        /* :: Var a -> Var a -> Bool       */
  3034.     Cell y = primArg(1);
  3035.     eval(x);
  3036.     eval(y);                /* I'm not sure this is correct       */
  3037.     updateRoot(x==y ? nameTrue : nameFalse);
  3038. }
  3039.  
  3040. primFun(primLvGetch) {            /* get character from stdin       */
  3041.     updateRoot(mkChar(readTerminalChar()));
  3042. }
  3043.  
  3044. primFun(primLvPutchar) {        /* print character on stdout       */
  3045.     eval(primArg(2));            /* putchar c () ==> ()           */
  3046.     putchar(charOf(whnfHead));
  3047.     updateRoot(UNIT);
  3048. }
  3049.  
  3050. primFun(primLvSystem) {            /* do system call           */
  3051.     String s = evalName(primArg(2));    /* system s () ==> int result       */
  3052.     Int    n = s ? system(s) : 1;
  3053.     updateRoot(mkInt(n));
  3054. }
  3055. #endif
  3056.  
  3057. /* --------------------------------------------------------------------------
  3058.  * Lambda-nu prototype implementation:
  3059.  * ------------------------------------------------------------------------*/
  3060.  
  3061. #ifdef LAMBDANU
  3062. Void lnExecute(prog)            /* execute lambda nu prog of type  */
  3063. Cell prog; {                /* Cmd a ()               */
  3064.     Cell temp;
  3065.     noechoTerminal();
  3066.     temp = evalWithNoError(ap(prog,nameLnDone));
  3067.     if (nonNull(temp))
  3068.     abandon("Command execution",temp);
  3069. }
  3070.  
  3071. primFun(primLnDone) {            /* lambda nu done           */
  3072.     updateRoot(UNIT);            /* behaviour is ignored, so isn't  */
  3073. }                    /* really important           */
  3074.  
  3075. primFun(primLnReturn) {            /* lambda nu return           */
  3076.     updapRoot(primArg(1),primArg(2));    /* return    :: a -> Cmd d a       */
  3077. }                    /* return a c = c a           */
  3078.  
  3079. primFun(primLnBind) {            /* lambda nu bind           */
  3080.     Cell a = primArg(3);        /* (>>=)::Cmd c a -> (a -> Cmd c b)*/
  3081.     Cell b = primArg(2);        /*            -> Cmd c b */
  3082.     Cell c = primArg(1);        /* (a>>=b) c = a (flip b c)       */
  3083.     updapRoot(a,ap(ap(nameLnFlip,b),c));
  3084. }
  3085.  
  3086. primFun(primLnFlip) {            /* flip primitive, for use in bind */
  3087.     updapRoot(ap(primArg(3),primArg(1)),primArg(2));
  3088. }
  3089.  
  3090. primFun(primLnNew) {            /* lambda nu allocate variable       */
  3091.     Cell c = primArg(1);        /* new :: Cmd a (Tag b)           */
  3092.     updapRoot(c,ap(nameTag,nameLnUnbound));
  3093. }
  3094.  
  3095. primFun(primLnAssign) {            /* lambda nu assign           */
  3096.     Cell v = primArg(3);        /* assign:: Tag a -> a -> Cmd d () */
  3097.     Cell e = primArg(2);            /* assign (Tag v) e c = c ()       */
  3098.     Cell c = primArg(1);
  3099.     eval(v);
  3100.     if (whnfHead!=nameTag || whnfArgs!=1)
  3101.     internal("type error in assign");
  3102.     snd(v) = e;                /* Arrgh! impurity!           */
  3103.     updapRoot(c,UNIT);
  3104. }
  3105.  
  3106. primFun(primLnRead) {            /* lambda nu reader           */
  3107.     Cell vv = primArg(3);        /* (?) :: Tag a -> (a -> Cmd d b)  */
  3108.     Cell b  = primArg(2);        /*            -> Cmd d b */
  3109.     Cell c  = primArg(1);        /* (Tag v ? b) c = b v c       */
  3110.     eval(vv);
  3111.     if (whnfHead!=nameTag || whnfArgs!=1)
  3112.     internal("type error in reader");
  3113.     updapRoot(ap(b,pushed(0)),c);
  3114. }
  3115.  
  3116. primFun(primLnIo) {            /* lambda nu i/o           */
  3117.     updapRoot(primArg(2),primArg(1));    /* io :: ((a->d)->d) -> Cmd d a       */
  3118. }                    /* io a c = a c               */
  3119.  
  3120. primFun(primLnBegin) {            /* lambda nu begin           */
  3121.     updapRoot(primArg(1),nameLnNocont);    /* begin :: Cmd d a -> d       */
  3122. }
  3123.  
  3124. primFun(primLnTagEq) {            /* lambda nu equality for Tags       */
  3125.     Cell x = primArg(2);        /* :: Tag a -> Tag a -> Bool       */
  3126.     Cell y = primArg(1);
  3127.     eval(x);
  3128.     eval(y);                /* I'm not sure this is correct       */
  3129.     updateRoot(x==y ? nameTrue : nameFalse);
  3130. }
  3131.  
  3132. primFun(primLnGetch) {            /* get character from stdin       */
  3133.     updapRoot(primArg(1),mkChar(readTerminalChar()));
  3134. }
  3135.  
  3136. primFun(primLnPutchar) {        /* print character on stdout       */
  3137.     Cell c = primArg(1);        /* putchar    :: Char -> Cmd a ()  */
  3138.     eval(primArg(2));            /* putchar x c = c ()           */
  3139.     putchar(charOf(whnfHead));
  3140.     updapRoot(c,UNIT);
  3141. }
  3142.  
  3143. primFun(primLnSystem) {            /* do system call           */
  3144.     Cell   c = primArg(1);        /* system    :: String -> Cmd a Int*/
  3145.     String s = evalName(primArg(2));    /* system s c = c (int result)       */
  3146.     Int    n = s ? system(s) : 1;
  3147.     updateRoot(mkInt(n));
  3148. }
  3149. #endif
  3150.  
  3151. #endif
  3152.  
  3153. /* --------------------------------------------------------------------------
  3154.  * Build array of character conses:
  3155.  * ------------------------------------------------------------------------*/
  3156.  
  3157. static Cell consCharArray[NUM_CHARS];
  3158.  
  3159. Cell consChar(c)            /* return application (:) c       */
  3160. Char c; {
  3161.     if (c<0)
  3162.     c += NUM_CHARS;
  3163.     return consCharArray[c];
  3164. }
  3165.  
  3166. /*-------------------------------------------------------------------------*/
  3167.